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ABSTRACT 

The FORTRAN programs supplied in this document provide a complete 
processing package for statistically extracting residual core, external field and lithospheric 
components in Magsat observations. The data reduction method consists of two stages 
involving pass-to-pass and gridded map comparisons. To process the individual passes: 1) 
orbits are separated into dawn and dusk local times and by altitude, 2) passes are selected 
based on the variance of the magnetic field observations after a least-squares fit of the core 
field is removed from each pass over the study area, and 3) spatially adjacent passes are 
processed with a Fourier correlation coefficient filter to separate coherent and non-coherent 
features between neighboring tracks. In the second stage of map processing: 1) data from 
the passes are normalized to a common altitude and gridded into dawn and dusk maps with 
least squares collocation, 2) dawn and dusk maps are correlated with a Fourier correlation 
coefficient filter to separate coherent and non-coherent features; the coherent features are 
averaged to produce a total field grid, 3) total field grids from all altitudes are continued to a 
common altitude, correlation filtered for coherent anomaly features, and subsequently 
averaged to produce the final total field grid for the study region, and 4) the total field map 
is differentially reduced to the pole. Source code which provides standard statistical 
information is also supplied to quantify the performance of the data reduction procedures. 
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I. INTRODUCTION 


The National Aeronautics and Space Administration (NASA) magnetic field 
satellite (Magsat) has provided a global data set of geomagnetic field observations. Data 
retrieved from the satellite have been reviewed by NASA and made available for scientific 
investigations as the Chronicle and Investigator-B data sets (Langel et al., 1981). Both data 
sets have been used to evaluate magnetospheric effects, to define the core field and to 
determine magnetic anomalies at satellite altitudes associated with geologic features. The 
documentation and FORTRAN source code supplied in this technical memorandum 
describe a step by step method for processing the Investigator-B data set. The processing 
helps to define the magnetic anomaly field from lithospheric sources, the influence of 
external fields, and possible residual core field effects which are not included in current 
models (e.g., Alsdorf 1991). 

The FORTRAN source code has been developed for processing the Investigator-B 
tapes. However, with adaptations the code could also be applied to the Chronicle series 
tapes or to other geophysical data sets (e.g., the magnetic field information from the POGO 
satellites). The code was developed in a UNIX-based environment on color graphics 
workstations such that compiled versions require user input at the terminal. Default values 
are noted for all user input variables, thereby facilitating the interactive nature of the 
processing. Graphics programs are not supplied in this document; however, the gridded 
data produced by the processing is formatted for standard contouring packages. 

The data reduction process was broken into several steps so that modifications to 
the code could be more easily applied. Also, output from each step can be investigated for 
refinement purposes by changing the values supplied by the user. The flow chart in Figure 
1 outlines each step of the data reduction process and should be referred to for the 
filenames described in this document. The first stage of processing operates on the 
individual passes while the second stage processes gridded forms of the data. For study 
areas covering about one fifth of the globe, it takes about two or three hours of operator 
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time on a RISC-based computer to generate differentially reduced-to-the-pole grids from 
the orbital data contained on the Investigator-B tapes. Subsequent runs through the data to 
adjust the variables will take less time because several of the programs need to be run only 
once for a study area. 

A full consideration of the theoretical details of these processing procedures is 
beyond the scope of this report. These details are found in the references cited in the 
software and this report. Additional discussions and explanations can be found in Alsdorf 
et al. (1991; 1992). 

There are six programs (Appendix B) used to process the satellite magnetic data 
from the individual orbits and five programs (Appendix C) that refine the data in grid 
form. Several auxiliary programs (Appendix D) are also provided to evaluate the output at 
different steps of the processing. Appendix A outlines the compile- and run-time 
considerations, disc storage allocation, and notes several improvements that could be made 
to the various programs. Chapter II describes the processing of the profiles while Chapter 
III details the processing of the grids. 
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II. PASS PROCESSING 


The programs used in this section include: 1) subcore, 2) reorder, 3) massage, 4) 
movetrunc, 5) fourierld and 6) combine. Appendix A should be reviewed for initial set 
up information before executing these programs. The following programs are presented in 
the appropriate running order. 

II.A SUBCORE 

After compiling each program and copying the data from the Investigator-B tapes 
to disc (Appendix A), the first program to run is subcore. This program reads the data in 
either sequential or direct access and writes to disc in direct access. Refer to the comment 
statements in the program when changing the code from the sequential access to the direct 
access driver. Each written record corresponds to an individual observation point as 
recorded by the satellite. For each record the first two values are integers (fixed point 
numbers) indicating the pass number and modified Julian day, respectively, and the 
remaining values are reals (floating point numbers) indicating location coordinates, core 
field values and vector magnetic field observations. NASA Technical Memorandum 
82160 (Langel et al., 1981) should be consulted for a complete description of these 
variables. The order of the input files from the tape to disc transfer should be in the same 
time order as recorded by the satellite. This order will maintain the time orientation of the 
data which is convenient for subsequent processing. However, this rule is not absolutely 
necessary because program reorder can readjust the data to any required time or space 
orientation, as explained in Section II.B. 

A review of the program description and comment statements in the code provides 
a complete assessment of the adjustments that are made to the data in subcore. The major 
functions of subcore are: 1) acquire only the data within user-defined latitude and longitude 
limits, 2) separate an individual orbit into its dawn and dusk components, and 3) calculate 
the core field value at each observation point. The spherical harmonic coefficients through 
degree and order 13 are used to model the core field and are presented in Appendix B. 
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After the core field value is subtracted from the observed value a series of values is written 
to disc. Not all of these values are necessary for future processing and some could be 
removed from the write statements if disc storage is limited. The subtraction of the core 
field from the magnetic field observations is not a profile-least-squares procedure (Alsdorf, 
1991). The least-squares method of subtraction is performed in program massage 
(Section II. C). After subcore is complete, the data files from the tape to disc transfer can 
be removed from disc storage because the processing no longer accesses these files. 

Separate files containing dawn passes and dusk passes are written by subcore to 
disc. These files are run separately through the remaining programs that process the 
profiles (Figure 1). 

II.B REORDER 

The major function of reorder is to rearrange the input file from a time to a spatial 
orientation. Ordering the passes by location in space is according either to the average 
longitude of a pass (the usual choice) or by the average elevation. Reordering the passes by 
time or pass number is also an option, however, it is seldom used. This program reads the 
direct access output from subcore and also writes out direct access files. This program 
requires twice the disc space as the size of the input file because it is necessary to create a 
working file which can be deleted after the run is complete. Once reorder has been 
completed, the 2-integer and 27-real output file from subcore can be deleted because the 
file is no longer necessary for processing. 

Subcore and reorder complete the standard preliminary processing of Magsat 
data. The output from reorder should be saved, even after running further programs, 
because data parameters may need adjustments when refining the final output. These 
adjustments often include rerunning the programs described below. 

II.C MASSAGE 

As originally designed, massage developed a combination of local and regional 
models of the data in an attempt to remove external field effects by Fourier correlation 
coefficient filtering. This method encompasses the construction of a "guide function" 
which is an approximate representation of the influence of external fields in an individual 
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pass. The guide function and the observations are then transformed by the Fourier 
program (Section II.E) and wavenumber components which correlate within a user defined 
range of correlation coefficients are cut from the observed data. Those components which 
correlate represent the effects of unwanted external fields and are therefore cut from the 
observed spectrum. However, after many investigations it was found that bandpass 
filtering could provide acceptable results with less computation and disc storage 
requirements than the guide function method. However, the options to construct the guide 
function are still included in massage for any research that may require a cubic spline fit to 
the data. 

The major functions of massage are now usually limited to the following: 1) 
remove "spikes" from a profile and linearly interpolate all values at latitude intervals of 
0.33 degrees, 2) calculate and subtract a least-squares profile fit of the core field values 
from the observed values, and 3) write out two corresponding files of an individual profile 
where one file contains the latitude, longitude and radius (e.g., dk.llr in Figure 1) while the 
other file holds the magnetic field value for each interpolated observation point (e.g., 
dk.var). Note that output files from massage are sequential access and considerably 
smaller than previous files because each profile is marked by only one header and either 
three or one variable(s) depending on file type. 

II.D MOVETRUNC 

This is the step where the dawn and dusk data sets are subdivided further into 
altitude bands (Alsdorf et al., 1992). The number and distribution of passes for each 
altitude band must be maintained to ensure a small distance between adjacent passes as 
compared to the distance to the lithosphere. For example, over the south polar region there 
are over 2500 dawn and dusk passes available from Magsat. After separation into four 
distinct altitude bands, there are over 500 passes for each local time at each altitude 
(Alsdorf et al., 1992), thus maintaining the density of observations for each band. Non- 
polar regions will have fewer passes because of the orientation of the satellite, therefore, 
these regions will probably have less than four altitude bands. For the purposes of this 
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report we will consider only two bands of altitude separation; lower and upper altitude 
passes. Therefore, after running movetrunc, four sets of data will exist including upper 
and lower altitude dawn data and upper and lower altitude dusk data. 

Before movetrunc is run, the program check as described in Appendix D should 
be executed to find passes with unacceptably high variances. Also, the output file of 
"averaged sorted variables" from reorder should be copied and edited for profiles that are 
above or below the median elevation. Appendix A reviews the UNIX commands which 
can be used to create the files of pass numbers that separate the passes into upper and lower 
altitude sets. 

Movetrunc reads the file of latitudes, longitudes and radii (e.g., dk.llr) as well as 
the corresponding file of magnetic field values (e.g., dk.var) produced from running 
massage. After removing unwanted passes, adjacent profiles are truncated to similar 
lengths according to the latitude value of each observation along a pass. Figure 2 
schematically shows how the passes are truncated. Note that pass 6 is duplicated; one 
version (6w) is truncated to match the length which overlaps with pass 5 and the other 
version (6e) is truncated so that it has the same overlapping section as pass 7. This 
duplication and truncation procedure is repeated for every pass. Reviewing Figures 1 and 
2, pass 6 is comparable to dk.llr and dk.var, 6w is similar to dk.low.llr.y and dk.low.y, and 
6e is like dk.low.llr.x and dk.low.x. Therefore, two sets of files, offset by one pass, are 
written to disc so that program fourierld (Section II.E) can correlate the immediately 
adjacent profiles. 

II.E FOURIER1D 

This program performs the fast Fourier transform (FFT) and inverse FFT as well 
as bandwidth and/or correlation coefficient filtering. Complex number notation is used to 
denote the wavenumber components in the memory of the computer. Options are 
provided for folding out the edges of the data, smoothing the edges to zero to minimize 
Gibbs energy effects, and centering the data within an array of zeros. Note that the 
subroutines of this program are one dimensional versions of those used in fourier2d 
(Section III.B) 
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The following example demonstrates the size of arrays to use, the percent of data to 
be folded out and the percent of data to be smoothed to zero in any application. First 
assume that the study area has a latitude range of 40 degrees. This range results in 121 data 
points: 

121 data points = (40 degrees)/(0.33 degrees per data point) (1) 

The size of FFT array to use should then be set to a power of two greater than 121 data 
points (128 or 256). In this case 128 allows for minimal folding and smoothing, so that 
better performance is obtained when 256 is used. The percentage of data to be folded out 
can be then calculated by 

(2 * 121 * X%) + 121 < 256 (2) 

In using equation 2, the X percentage chosen must satisfy the less than sign. If for 
example we chose 10 percent, then for 121 data points, 12 values at each end of a pass will 
be folded out and added to the beginning or end of the profile, so that there are 145 data 
points (145=12+121+12). The following sequence illustrates the mirror folding of data 
points at each end of the profile obtained by fourierld. 

12, 11. ... 2, 1, 1,2, ... 11, 12, 13, ... 109, 110, 111, ... 120, 121, 121, 120, ... Ill, 110 

folded data — I original data 1 folded data 

The percent of data to be smoothed to zero must satisfy 

(145 * Y%) <12 (3) 

where the Y percentage is chosen so that only the data folded out are smoothed and not the 
actual data. In this case we might chose a Y percent of 8% which smooths 1 1 values of 
each edge of 145 data points (1 1=0.08 * 145). Finally the program will center the 145 data 
points within the FFT array by adding 55 zeros to the beginning and 56 zeros to the end of 
the 145 data points (55,56= {256- 145} * 0.5). When the final data set is written to file after 
inverse transforming, only the original 121 data point positions are used. 

This is the first application of the fourierld program and the user should consider 
bandpass and correlation coefficient filtering of the data at this time. 

ILF COMBINE 

Combine is run twice when processing the data. In this first application of the 
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program, the two output files of latitudes, longitudes and radii (e.g., dk.low.llr.x and 
dk.low.llr.y) from movetrunc were identical except for an offset of one pass between the 
files. After fourierld is applied in ILE, combine is used to find the same pass in the two 
files and truncate both versions of the pass to a similar length. This application of combine 
as illustrated in Figure 2 is analogous to truncating 6w and 6e so that both of these versions 
of pass 6 are of similar overlapping lengths. Therefore, it is important to input the files in 
the correct order. However, combine will check to see that the user has input the files 
correctly and if not, will stop execution of the program and issue a warning to the screen. 
II.G FOURIER1D 

This is the second use of fourierld on the profiles. Here, the passes should only 
be correlation filtered for similar wavelengths. Bandpass filtering is usually not performed. 

II.H COMBINE 

This is the second use of combine on the profiles. The output of combine is 
chosen as one file of latitudes, longitudes, radii and anomaly values (e.g., dk.low.llra) 
which will be input to collocation as described in section III.A for gridding. This single 
output file is written to disc in formatted- ASCII, sequential-access so that the file may be 
easily transferred from a workstation to a supercomputer. 

This concludes the data processing as applied to passes. 
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III. MAP PROCESSING 


Programs applied for map processing include: 1) collocation, 2) fourier2d, 3) 
avgdifres, 4) sqrmap and 5) inversion. Before executing these programs, Appendix A 
should be reviewed for initial set up information. 

Before the programs in this chapter are run, the output file of latitudes, longitudes, 
radii and anomalies from combine (Section II. H) should be transferred from the 
workstation platform to a supercomputer. This transfer is not absolutely necessary, 
however the computing speed of a supercomputer facilitates faster processing of matrix 
inversions and large two-dimensional Fourier transforms. 

The four sets of profile data (i.e., upper and lower altitude dawn and dusk orbits) 
were each processed independently as described in Chapter II. When processing the grids 
in this chapter, the lower altitude dawn and dusk grids are compared and the upper altitude 
dawn and dusk maps are compared. At the end of the processing, the lower and upper 
altitude total field maps can be continued to the same elevation and subsequently correlated 
and averaged (Alsdorf et al., 1992). The following discussion only addresses a single 
altitude set of dawn and dusk data, although the other altitude data will also be processed in 
the same manner to test for lithospheric anomaly features sets. 

The program statmat included in Appendix D can be run using any combination 
of the following grids as input. Statmat determines a variety of standard statistics 
necessary for interpretation of the magnetic anomalies and the quality of processing. 

The following programs are presented in correct running order. 

III.A COLLOCATION 

Collocation reads the ASCII free format file from combine (e.g., dk.low.llra), 
which includes arbitrarily distributed data points throughout the study region, and calculates 
node values at regular intervals over a grid at constant altitude (Goyal et al., 1991; Goyal, 
1986). The output grid file from collocation is formatted ASCII, where the first row of 
values in the file is along the southern most latitude from west to east. Coordinates for the 
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first data point in the array are the western most longitude and the southern most latitude. 
The next data point is just one grid interval to the east of the first data point and along the 
latitude coordinate. The remaining data points in the row are successively one grid interval 
east of the preceding point. The next row of values follows the same west to east 
orientation as the first row, however this row is one grid interval to the north of the first 
row. The remaining rows then fill the grid successively from south to north and west to 
east. All programs that work with the grids keep this same orientation. 

The user supplied covariance matrix (Appendix C) that is used in collocation has 
been found to produce acceptable magnetic anomalies (Goyal et al., 1991; Goyal, 1986). 
The covariance matrix provides a function that is used to calculate weights based on 
distances between grid nodes and observation points. 

Both a dawn grid and a dusk grid at the same altitude are produced by separate runs 
of collocation. These grids correspond to the respective sets of passes from the profile 
processing. The elevation of the grids should be the same and is commonly chosen as the 
average elevation of all observations in the dawn and dusk data sets. Collocation can be 
used to predict values at grid points which are separated by distances of equal degrees or 
equal lengths. For example, when working over the polar regions, the FFT algorithms and 
filtering routines work best with grids of equal areas denoted by the grid coordinates of 
equal length separations. The program comment statements should be reviewed for 
appropriate input parameters when choosing between the above grid coordinate options. 
III.B FOURIER2D 

The forward and inverse FFT subroutines of this program are the two dimensional 
versions of those in fourierld (Section II.E). Fourier2d offers several data processing 
filters including both the bandpass and correlation coefficient routines. Additional filters 
are also included which are not typically used in the Magsat data processing; however, 
these routines are made available for expanded processing efforts. The directional filtering 
routine fashions a wedge-shaped filter to pass/reject directional trends of data features, 
whereas the remaining routines perform flat-earth upward and downward continuation, 
flat-earth reduction of magnetic total field anomalies to the pole, obtain flat-earth anomaly 
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derivatives, and adjust the phase and amplitude of the individual wavenumber components. 
For spherical-earth applications, both the continuation and reduction to pole of data is more 
suited and better constrained by the matrix inversion methods of program inversion 
(Section ELI) and, therefore, Section III. I should be reviewed for these data processing 
methods. 

The main calling routine of fourier2d also differs from fourierld in that it does 
not loop through successive profiles or maps and it allows for multiple calls to the filters in 
any user-defined order. The comment statements of fourier2d should be reviewed for the 
correct user input values which control the order and number of times a particular filter is 
called. 

The dawn grid is correlated with the dusk grid such that the correlation coefficient 
cutoffs are set to pass the coherent and consistent anomalies. The size of the FFT array, the 
percent of data to be folded out and the percent of data to be smoothed are calculated in 
similar fashion to those of the profiles as described in Section II.E. However, because 
these values are applied to the columns as well as to the rows of the matrix, the various 
percentages will be determined by both the number of rows and columns. The input Y% 
should be chosen so as not to smooth actual values within the array. 

This is the first use of fourier2d as applied to the grids and the user should only 
choose to apply the coefficient filter to the two grids. Alsdorf et al. (1992) review 
appropriate correlation cutoff values for the south polar region where the auroral external 
field influences are significant; other regions may require different values depending on the 
effects of external fields in those areas. 

III.C AUXILIARY MAP PROCESSING 

The grid processing steps of this section are not necessary for standard map 
reductions; however, these steps are presented for completeness. The processing of this 
section removes possible external field influences manifested as coherent differences 
between the correlated dawn and dusk maps. Also, the standard deviations (ie. energy 
levels) of the correlated dawn and dusk maps are adjusted to nearly the same level. 
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III.C.1 AVGDIFRES 


This program can be run up to three times during the data processing; once in this 
auxiliary section and possibly twice in standard processing. In this initial application, 
avgdifres is used to calculate the difference between the correlated dusk and dawn grids 
(e.g., low.diffl). 

III.C.2 FOURIER2D 

This is the second application of fourier2d on the grids. Here, the difference grid 
from avgdifres (e.g., low.diffl) is smoothed with a high-cut filter so that a long 
wavelength model of the possible influence of external fields is produced. 

III.C.3 SQRMAP 

At this point, both the difference grid and its low-pass filtered version should be 
visually inspected to determine if the differences can serve as a model of the expected 
effects of external fields for the study region. If so, then sqrmap subtracts the filtered 
difference matrix from the correlated dusk or dawn grid. Before the subtraction, the 
difference matrix is least- squares adjusted to more closely match the correlated dusk or 
dawn grid under consideration. 

This concludes the auxiliary processing section. 

III.D AVGDIFRES 

This is the second application of avgdifres to the grids. As applied here, avgdifres 
finds the average and the difference of the correlated dusk and dawn grids produced from 
either fourier2d in III.B or sqrmap in III.C.3. 

III.E FOURIER2D 

This is the final application of fourier2d to the grids. With this application the 
averaged grid from avgdifres (III.D) is high-cut filtered to remove wavelengths shorter 
than the elevation of the data set. Magnetic anomaly wavelengths smaller than the 
magnitude of the elevation of the grid are not apparent at satellite altitudes. 

The high-cut filtered output map from this execution of fourier2d represents the 
total field magnetic anomaly map at the particular altitude which is being considered. 
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III.F MODELING OF THE MAGNETIC ANOMALIES 

The processing of the previous sections is repeated over each altitude band (e.g. 
both the lower and upper altitudes) producing a total field grid for each altitude. As 
discussed in this section, each total field grid is individually continued to a common altitude 
using the inversion program, then all continued grids are averaged to produce the final total 
field grid for the study region. This total field grid can then be differentially-reduced-to- 
the-pole (DRTP) for geologic interpretations and comparisons with gravitational 
anomalies. 

III.F.1 AVGDIFRES 

This is the final application of avgdifres to the grids. Here the smoothed grid from 
fourier2d (III.E) is resampled so that the output matrix can be inverted within the 
interactive memory allocation of a supercomputer. Generally, resampling should occur at a 
grid interval less than the high-cut wavelength used in fourier2d. This step is not 
necessary if precautions are taken as described below in section IC.F.2. 

III.F.2 INVERSION 

This modeling program finds the effective susceptibilities which correspond to the 
total field grid supplied by avgdifres (III.F.1) or fourier2d (III.E) (von Frese et. al., 1981; 
1988). These susceptibilities are then subjected to a core field model to produce the total 
field anomalies at a user defined altitude, or the susceptibilities can be subjected to a radial 
field of constant intensity to model the DRTP anomalies. These procedures are equivalent 
to spherical-earth continuation of the Magsat data. To find the susceptibilities, a core field 
model expanded through degree and order 13 which can be updated to the mission lifetime 
is necessary (e.g., Appendix B). If the subject area is large and results in more unknowns 
than the memory allocation of an interactive session on a supercomputer allows, then one 
of the following can be applied: 1) a boot strap inversion (von Frese et al., 1988), 2) the 
matrix inversion routines can be modified to write and read from disc rather than memory, 
or 3) use batch submission so that the code will be executed during a period of reduced 
user demand (Appendix A). Documentation in inversion describes cpu storage and time 
requirements in terms of the number of unknowns for any inversion. 
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After all of the total field grids are continued to an average altitude, the continued 
grids can be correlation filtered using fourier2d and subsequently averaged together to 
produce the final total field grid for the study area. The algorithms of the averaging code 
are rather straightforward, and we do not present them in this document. However, the 
code is available via email as outlined in Appendix A. The continued total field grids can 
be compared to test the self-consistency of anomaly features. Comparisons are facilitated 
by differencing the grids and statistical analyses. 

This concludes the data processing as applied to the grids. 
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IV. CONCLUSION 


The FORTRAN programs supplied in this document provide processing capabilities 
for investigating lithospheric, external field, and residual core components in the Magsat 
data. For extracting lithospheric anomalies, the data processing begins with reading the 
NASA Investigator- B files and finishes with a differentially-reduced-to-the-pole magnetic 
anomaly map of the study region. 
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Figure 1: Processing flow chart. Program names are given in boxes and suggested file names follow the arrows. All names 
are used in the manuscript and values in parantheses are indexed to the appropriate chapter or appendix. 
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Figure 1 (continued from page 17) 

* If more than two altitude bands are used, then avgdifres can not be used at this point. An auxiliary 
program to average all correlated continuations is available via email (as described in Appendix A). 
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Figure 2 Pass-to-pass processing schematic showing the application of the 
correlation filter of program fourierld and the truncation of passes by programs 
movetrunc and combine. Pass labeling convention follows from the text and 
program labels are from Figure 1. 
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APPENDIX A: DATA EDITING AND COMPUTING REQUIREMENTS 

This section describes the computing environment necessary to compile and 
execute the FORTRAN source code as well as disc storage estimates for the files. 
Additional comments address UNIX commands used to create various input files and 
possible improvements to the code to increase speed and decrease total file storage 
requirements. 

A.l COMPUTING ENVIRONMENT 

The source code was written, compiled and executed on DEC 3100 color graphics 
workstations with the Ultrix operating system. Source code in Appendix C was also 
compiled and executed on the Ohio Supercomputer Center's CRAY Y-MP8 which 
operates with UNICOS. Other computing systems with FORTRAN 77 compilers should 
compile, link and execute the code with little or no modifications. Programs subcore.f, 
reorder.f and massage.f use direct access for file reads and writes and need to be modified 
for the specific operating system. The comment statements in these programs should be 
reviewed for additional information. After the code has been transferred to a FORTRAN 
source code directory, the individual programs should be compiled with the following 
Ultrix command: 

Ultrix prompt: f77 -static programname.f 
or with the following UNICOS command: 

UNICOS prompt: cf77 -Zp -Wf '-a static" programname.f 
The -Zp option allows for optimal autotasking and vectorization and -static permits the 
local variables to be statically allocated. The executable file, a.out created by running the 
FORTRAN compilier command can be moved to the users bin directory and given the 
same name as the programname without the .f extension. When executing any of the 
programs, the user is prompted at the screen (standard input/output device) for filenames 
and parameters for variables. The variables all have default values listed inside parentheses 
and the user can type these values as desired. Filenames are suggested in the flow chart of 
Figure 1. 
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When running the code on the CRAY, it is convenient to use the batch submission 
procedures for the inversion code (section III.F.2) because it may require more memory 
than is allocated under an interactive session. The following is a typical example of the 
batch submission method: 

UNICOS prompt: qsub -1M lOMw -IT 3600 shellfile 
The -1M lOMw allocates 10 megawords (80 megabytes) of memory and -IT 3600 
provides 60 minutes of cpu time to run the code in the shell file. Consult the CRAY 
manual pages for more information. 

The total size of the three Investigator-B tapes is around 300 Megabytes (Mb) on a 
DEC 3100, however other machines may double the size depending on the default number 
of bytes used to define floating and fixed point numbers. For study areas that constitute 
about one fifth of the globe, disc storage requirements to run subcore range between 45 
and 70 Mb depending on global location. To run reorder, 90 to 140 Mb are necessary. 
Between 3 and 6 Mb are needed to run any of the remaining programs in Appendix B. 
The dawn and dusk grids are generally less than 400 Kilobytes (Kb). 

A.2 HELPFUL UNIX COMMANDS 

This section describes how to produce files of pass numbers which remove the 
high variance passes as well as subdivide the passes into altitude sets (e.g. lower and upper 
altitudes). As defined here, filel contains those passes with a variance above a threshold; 
file2.1ow and file2.hi hold pass numbers of either the lower or upper (respectively) altitude 
pass numbers; and file3.1ow and file3.hi include both the large variance pass numbers and 
the lower or upper altitude pass numbers. The following sequence of commands must be 
executed once for the dawn data and once again for the dusk data. 

As discussed in section II. D, check is run immediately before movetrunc. Once a 
maximum variance cutoff has been established, check should be run in a UNIX script 
shell as follows: 

UNIX prompt> script filel 

script prompt> check 

script prompt> 1 (type 1 and hit the return) 
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script prompt> output file from massage (e.g., dk.var) 
script prompt> 1 

script prompt> 200.0 200.0 200.0 -200.0 500.0 

(these are suggested values) 

script prompt> yes 

script prompt> output file from reorder (e.g., dk.pass) 
script prompt> a new file (e.g., file2) 

Now several hundred pass numbers will be written to the screen and to filel. After the 
program is finished, exit out of the script shell and use a text editor to access filel. 
script prompt> exit 

UNIX prompt> vi filel (or use any other editor) 

Once in the editor, remove every line except those with pass numbers on them so that the 
final version of filel resembles the following line. 

1074 129 75.982 -0.023 -29.244 18.222 1087.460 

Filel now contains the pass numbers of those passes which have a variance above the 
user-defined maximum (in this case 500.0 nT^). 

Next, make two copies of file2 so that the pass numbers can be separated into low 
and high altitude sets. 

UNIX prompt> cp file2 file2.1ow 
UNIX prompt> cp file2 file2.hi 

Edit file2.1ow with a text editor, removing all lines where the average elevation is above the 
median elevation. The median elevation occurs at the mid-line in the file (e.g., if there are 
1400 lines in file2, then the median elevation occurs on line number 700). Similarly, edit 
file2.hi removing all lines where the average elevation is below the median elevation. 
Finally, combine the edited file2.1ow and file2.hi with filel as follows: 

UNIX prompt> cat file2.1ow filel > file3.1ow 
UNIX prompt> cat file2.hi filel > file3.hi 

While processing the lower altitude passes, file3.hi is input to movetrunc when the 
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program asks for "input file of pass numbers not wanted". Conversely, file3.1ow is input 
to movetrunc when processing the upper altitude passes. 

A.3 SUGGESTED IMPROVEMENTS 

Several improvements to the code to lower run time and decrease file sizes could be 
made. The following improvements concentrate on the programs that process the 
individual profiles as described in Appendix B: 

1. subcore: Arrays that are in part named "data" could be combined so that the 
same array is passed to each subroutine. 

2. reorder: A better method of finding the average longitude of short passes may 
decrease total run time. 

3. movetrunc and combine: 

a) These two programs are very similar and with some modifications the programs 
could be combined. 

b) Because the output lat-long-radii files are similar, only one file containing flags 
indicating the index locations where the passes overlap is necessary for output. 

The following improvements concentrate on the programs in Appendix C that process the 
gridded maps. 

1. collocation: 

a) Invert only the symmetric half of the COVM array. 

b) Use a faster sorting routine for finding the closest points to a grid node location. 

2. inversion: For arrays larger than the allocated machine memory, an option 
should be inserted that uses disc space for the matrix inversion. 

As a final note, the source code is intended as a framework that allows step-wise 
processing of the Magsat data. This framework is open for improvements which are 
heartily encouraged. For copies of the code in this technical memorandum as well as 
additional auxiliary programs not presented in this document, send an email request to: 
alsdorf@geols.mps.ohio-state.edu -or- vonfrese@geols.mps.ohio-state.edu 
Comments, criticisms, suggestions for code improvements, as well as requests for code 
updates should also be directed to the above email addresses. 
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APPENDIX B: PROFILE PROCESSING 


PROGRAMS 

subcore.f 

reorder.f 

massage.f 

movetrunc.f 

fourierld.f 

combine.f 

DATA FILE 
gsfcl283 




A A 


program subcore 

realM rbuff (3024/4) ,minlat,maxlat , minion, maxlon, 

> seconds (3000) , rhead (2228/4 ) 

integer*4 ibuf f (3024/4) , flagl, flag2, headcnt , recnum, 

> outnum, dnnum, dknum, 

> dndkpass,datacnt,stoplO, stopll, 

> headlO, datalO, headll, datall , headl2,data!2, totrecord, 

> dnrec, dkrec, nowant (50) , ihead (2228/4 ) 
character* 80 filename 

character*4 cbuff (3024/4) , chead (2228/4 ) 
character* 60 aald 

equivalence (ibuf f, rbuff ) , (cbuff, rbuff ) , (flagl, ibuf f (1) ) , 

(f lag2, ibuf f (2) ) , (ihead, rhead) , (flagl, ihead (1) ) , 
(flag2, ihead(2) ) , (chead, rhead) 
common /latlon/ minlat,maxlat, minion, maxlon 
common /dndkdat/ dndata (1500, 26) , dkdata (1500, 26) , 

> i dndata (1500, 2) , idkdata (1500, 2) 

common /coeff/ gg (50, 50) , ggt (50, 50) ,ggtt (50, 50) , jnum, knum, 

> ttzero, aaid,mmaxn, ttemp 

common /mainfld/ fid (1500, 8) , dawne, dawni, duske,duski, dndkpass 
common /thatsit/ outdawn (1500, 27) ,outdusk{1500, 27) 

COMMON /NASA/ TG(50,50) 

COMMON /FLDC0M/ ST, CT, SPH, CPH, R, NMAX, BT, BP, BR, B 

COMMON /mag fid/ THETA (1500) , PHI (1500) , ELVO(l 500) , YEAR(1500) 

common data (3000, 26) , idata (3000, 2) 


c 

c program description 

c 

c subcore reads the 3 NASA INVESTIGATOR-B tapes from disc and obtains 

c the data for the user defined area, the program performs the following 
c corrections to the data: 1) reorders the dataset from NASA’s column 

c arrays to user manageable row arrays 2) removes all values at a 

c single sampling point if one of those values is flagged by NASA with 
c 9999 3) selects the data for the user defined area 4) separates 

c the area into dawn and dusk datasets 5) calculates the core-field 

c value for every data point along the dawn or dusk profile and saves 

c that value in an array 6) removes the core-field values from the 

c data point along a dawn or dusk profile 7) removes NASA's ring- 
c current correction and 8) writes several values to the output 

c files - these values can be determined by looking at subroutine 

c corering. 

c NOTE: output unformatted files are direct access 

c input unformatted files are sequential access 

c output formatted files are sequential access 

c NOTE: use NASA Technical Memorandum No. 82160 for a complete 

c description of each variable 

c 

c program date: 16 apr 91 

c 

c updates : 

c 4 jun 

c NOTE : 

c 
c 
c 

c NOTE: 

c 
c 
c 
c 
c 
c 
c 
c 

write (*,*) 'INPUT FIRST DATASET FROM TAPE TO DISC TRANSFER' 
read (*,9990) filename 
9990 format (a80) 

open (10, file-filename, status- 'old' , form- ' unformatted' ) 
write (*,*) 'INPUT SECOND DATASET FROM TAPE TO DISC TRANSFER 1 
read (*,9990) filename 

open (11, file-filename, status- 'old' , form-' unformatted' ) 
write (*,*) 'INPUT THIRD DATASET FROM TAPE TO DISC TRANSFER' 
read (*,9990) filename 

open (12, file-filename, status-'old* , form-' unformatted' ) 
write (*,*) 'INPUT FIELD MODEL SPHERICAL HARMONIC* 
write (*,*> 'COEFFICIENTS (GSFC1283) ' 
read (*,9990) filename 

open (13, file-filename, status-'old', form-' formatted' ) 

c use the following if you want to input your own nowant 

c file 

c write (*,*) *1 to remove certain pass numbers' 

c write {*,*) ' 0 do no remove any pass numbers' 

c read (*,*) nocnt 

c if (nocnt .ne. 0) then 

c write (*,*) 'input file of pass numbers not wanted' 

c read (*,9990) filename 

c open (14, file-filename, status- 'old' , form-' formatted' ) 

c do i-1,5000 

c read (14, *, end-10) nowant (i) 

c enddo 


92, added sequential access driver 

the input files are sequential access in this section 
to use direct access input files, then swap the 
driver at the end of the code with the currently used 
sequential access driver. 

if you are working on an ibm rs6000 then the record 
length for direct access on files 20 and 21 is: 
recl-1 16 

for input of direct access to files 10,11 and 12 then 
remove the /4 from 3024/4. 
if you are working on a dec3100: 
recl-29 

and keep 3024/4. 
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c 10 nocnt-i-1 

c endif 

c the following lines automatically place the nowant 

c pass numbers in the nowant array, these passes are 

c messed up for one reason or another, i'm sure they 

c could be salvaged, but i'm lazy. 


nowant (1) -909 
nowant (2) -1079 
nowant (3) -1206 
nowant ( 4 ) -2602 
nowant { 5) -2728 
nowant (6) -2744 
nowant (7) -2791 
nowant (8) -2854 
nowant (9) -3059 
nocnt-9 

write {*,*) 'OUTPUT DAWN DATA FILE OF 2-INTEGERS AND 27-REALS' 
read (*,9990) filename 

open (20, file-filename, form-' unformatted access- 'DIRECT ' , 

> recl-116) 

write (*,*) 'OUTPUT DUSK DATA FILE OF 2-1 AND 27-R' 
read (*,9990) filename 

open (21, file-filename, form-' unformatted' , access- 'DIRECT' , 

> recl-116) 

write (*,*) 'OUTPUT HEADERS FILE* 
read (*,9990) filename 

open (22, file-filename, form-' formatted' ) 
c 

write (*,*) '0 FOR NO ADDITIONAL INFORMATION* 
write (*,*) '1 FOR ONLY Dst INDEXES' 

write (*,*) '2 FOR COMPLETE INFORMATION... this is a big file' 
read (*,*) info 
if (info .gt. 0) then 

write (*,*) 'OUTPUT ADDITIONAL INFORMATION ORBIT FILE' 
read (*,9990) filename 

open (23, file-filename, form-' formatted' ) 
endif 
c 

write (*,*) 'MINIMUM AND MAXIMUM LATITUDE OF STUDY AREA' 

write (*,*) 'INPUT RANGE IS FROM -90.0 TO 90.0* 

read (*,*) minlat,maxlat 

write (*,*) 'MINIMUM AND MAXIMUM LONGITUDE OF STUDY AREA' 

write (*,*) 'INPUT RANGE IS FROM -180.0 TO 180.0' 

read (*,*) minion, maxlon 
c 

c the following arrays store the spherical 

c harmonic coefficients that describe the 

c core field 

READ (13,9926) Jn urn, Kn urn, Tt ZERO, AalD 
9926 FORMAT (211, IX, F6. 1, A60) 

MmAXN-0 

TtEMF-0. 

50 READ (13,9928) N, M, GNM, HNM, GTNM, HTNM, GTTNM, HTTNM 
9928 FORMAT (213, 6F11.4) 

IF (N.LE.0) GO TO 80 
MnAXN- (MAX0 (N,MnAXN) ) 

Gg (N, M) -GM4 

GgT (N,M) -GTNM 

GgTT (N, M) -GTTNM 

TtEMP-AMAXl (TtEMP, ABS (GTNM) ) 

IF (M.EQ.l) GO TO 50 
Gg (M-l , N) -HNM 
GgT (M-l ,N) -HTNM 
GgTT (M-l , N) -HTTNM 
GO TO 50 
80 CONTINUE 
c 

dnrec-0 

dXrec-0 

totrecord-0 

datacnt-0 

headcnt-0 

stoplO-O 

stopll-0 

c 

headlO-O 
datalO-O 
recnum-1 
100 num-1 

read (10, end-120) rhead 
headl Q-headl 0+ 1 
go to 220 
c 

120 stopl0-l 
close (10) 

write (*,*) 'done with file one' 

write (*,*) 'total headers on file one -*,headl0 

write (*,*) 'total data sets on file one -*,datal0 

headl 1-0 

datall-0 
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tot record- totrecord+recnum 
recnum-1 

* us« the go to 999 statement if you only 

• want to input one file at a time 
go to 999 

125 num-1 

read (11, end-150) rhead 
headll-headll+1 
go to 220 

150 s topi 1—1 

close (11) 

write (*,*) 'done with file two* 

write (*,*) 'total headers on file two -',headll 

write (*,*) 'total data sets on file two detail 

headl2-0 

datal2-0 

tot record-tot record+recnum 
recnum-1 
155 num-1 

read (12, end-999) rhead 
headl 2-headl 2+ 1 

220 continue 


c 

if 


> 

> 

> 

> 


8880 


c 

c 

230 

c 


c 

c 


> 


if then this is header file 

(flagl .eq. 1) then 
if (info .eq. 1) then 

write (23,*) ihead{4 ) , (rhead(i) ,i-23, 34) 
elseif (info .eq. 2) then 

write (23,*) (ihead (i) , i-1 , 4 ) , (rhead (i) , i-5, 8 ) , 

(ihead(i) , i-9, 10) , (rhead (i) , i-11, 14) , 

(ihead (i ) , i-15, 16) , (rhead (!) , i-17, 34) , 

(chead (i ) , i-35, 64 ) , (ihead (i) , i-65, 67) , 

(rhead(i) ,i-68, 557) 

endif 

write (22,8880) ihead(4) , (rhead (i) , i-5, 8) , (ihead(i) , i-15, 16) 

format (lx, iS, 4el5 . 7, 2i6) 

dndkpass-ihead (4 ) 

duske-rhead(5) 

duski-rhead (6) 

dawne-rhead (7) 

dawni-rhead(8) 

headcnt-headcnt+1 

recnum-recnum+ 1 

if (flag2 .eq. 2) then 

continue 

if (stoplO. eq. 0 .and. stopll.eq.0) then 
data 10-datal 0+1 
read (10, end-120) rbuff 
elseif (stoplO.eq.l .and, stopll.eq.0) then 
datal 1-datal 1+1 
read (11, end-150) rbuff 
elseif (stoplO.eq.l .and. stopll.eq.l) then 
datal 2-datal 2+1 
read (12, end-999) rbuff 
endif 

recnum-recnum+1 

datacnt-datacnt+1 

~ — - if f lagl-2 then this is a data file 


if (flagl .eq. 1) then 

write (*,*) 'problem with flagl -', flagl, 

'in a data record' 

stop 

endif 

do i-num, num+29 

idata (i, l)-ibuff (5) 
idata (i, 2) -ibuf f (3) 
xnum-real (i-num) 

seconds (i)- (real (ibuf f (4)) + (rbuf f (6) *xnum) ) 
enddo 


c 

c 


250 

c 


_ these do 250 loops reorder the data 

from column to row oriented data 

do 250 j-1,25 

do 250 i-num, num+29 
data (i, j) -rbuff ( j j } 

continue 


num-num+30 

c 



c 

c 

if (flag2 .eq. 1) then 
innum-num-1 


if flag2«l then the next record is 
a header and the data information is 
complete for this orbit 
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c 

C' 

c 

c 

c 

c 

c 

c 


> 


c 


270 


c 


c 


300 

310 

c 


350 

360 


c 

c- 

c 


> 


c 


c- 

c 


search the nowant array for passes 

that just didn't happen, the 
following passes are doubled and 
are considered not wanted: 

909, 1079, 1206, 2602, 2728, 2744,2791, 
2854,3059 

do i-l,nocnt 

if (nowant (i) .eq. idata(l,l)) then 
write (*,*) ‘removed pass number 
nowant (i) , idata (1,1) 

if (stoplO.eq.O .and. stopll.eq.0) go to 100 

if (stoplO.eq. 1 .and. stopll.eq.0) go to 125 

if (stoplO.eq. 1 .and. stopll.eq.l) go to 155 

endif 
enddo 

do 270 i-1, innum 

data (i, 26) -seconds < i ) 
continue 

call nine (innum,outnum) 

innum-outnum 

call area (innum, outnum) 

innum-outnum 

call dawndusk (innum, dnn urn, dkn urn) 

if (dnnum .le. 0) go to 310 
call pfligrf (dnnum, 1) 
call corering (dnnum, 1) 
do 300 i-1, dnnum 
dnrec-dnrec+1 

write (20, rec-dnrec) (idndata (i, j) , j-1, 2) , 

(outdawn (i , j ) , j-1 , 27 ) 

continue 

continue 

if (dknum . le . 0) go to 360 
call pfligrf (dknum, 2) 
call corering (dknum, 2) 
do 350 i-1, dknum 
dkrec-dkrec+1 

write (21, rec-dkrec) (idkdata (i, j) , j-1, 2) , 

(outdusk (i, j) , j-1, 27) 

continue 

continue 


these ugly little go to's get back to a 

header record 

if (stoplO.eq.O .and. stopll.eq.0) go to 100 

if (stoplO.eq. 1 .and. stopll.eq.0) go to 125 

if (stoplO.eq. 1 .and. stopll.eq.l) go to 155 

endif 

go back and get another data record 

go to 230 

endif 


c 


c 


c 


999 


c 

c 

c 


elseif (flag2 .eq. 1) then 

write (*,*) 'a header file had no associated data record* 
write (*,*) ‘this header file has pass number *,ihead(4) 
endif 

if (stoplO.eq.O .and. stopll.eq.0) go to 100 
if (stoplO.eq. 1 .and. stopll.eq.0) go to 125 
if (stoplO.eq. 1 .and. stopll.eq.l) go to 155 

continue 

write (*,*) 'total headers on file three -*,headl2 
write {*,*) 'total data sets on file three -',datal2 
write (*,*) 'total headers on tapes -',headcnt 
write (*,*) 'total data sets on tapes -*,datacnt 
tot record-tot record+recnum 

write (*,*) 'total records read -',totrecord 

write {*,*) 'total records written to dawn file -*,dnrec 

write {*,*) 'total records written to dusk file -',dkrec 

close (12) 

close (13) 

close (14) 

close (20) 

close (21) 

close (22) 

close (23) 

stop 

end 
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subroutine nine (innum, nincnt) 
common data (3000, 26) , idata (3000, 2) 


c 

subroutine description 

c this subroutine removes from the data array all variables 

c associated with a single sampling point if selected variables at 

c that sampling point are greater than 99999.0 

c 


nincnt-0 

c 

do 100 i-1, innum 
do 3-1,3 

if (data (i, j) .ge. 99999.0) go to 200 
enddo 
do j-5,6 

if (data (i, j) .ge. 99999.0) go to 200 
enddo 
do 3-8,23 

if (data (i, j) .ge. 99999.0) go to 200 
enddo 

if (idata (i,l) .ge. 9999) go to 200 
c if (data (1,1) . eq. 99999.0 .or. data (i, 2) .eq. 99999.0 .or. 

c > data (i f 3) .eq. 99999.0 .or. data (i, 8) .eq. 99999.0 .or. 

c > data (i, 12) .eq.99999.0) go to 200 
nincnt-nincnt+1 
do 140 j-l f 2 

idata (nincnt, j)-idata (i, j) 

140 continue 

do 150 j-1,26 

data (nincnt, j) -data (i, j) 

150 continue 

200 continue 

100 continue 
c 

return 

end 

c 

c 

c 

subroutine area (innum, outnum) 
integer*4 innum, outnum 
real*4 minlat ,maxlat , minion, maxlon 
common /latlon/ minlat, maxlat, minion, maxlon 
common data (3000, 26) , idata (3000, 2 ) 
c 

subroutine description 

c this subroutine removes all data outside of the user defined 

c area, 

c 

outnum-0 

do 200 i-1, innum 

if (data (i,l) .gt. maxlat .or. data (1, 1 ) .It .minlat .or. 

> data (i, 2} .gt. maxlon .or. data (i, 2 ) .It .minion) go to 100 
outnum-outnum+1 

do 140 3-1,2 

idata (outnum, j)-idata (1, j) 

140 continue 

do 150 j-1,26 

data (outnum, 3)-data (i, j) 

150 continue 

100 continue 

200 continue 
c 

return 

end 

c 

c 

c 

subroutine dawndusk (innum, dncnt, dkcnt) 

integer*4 innum, dncnt, dkcnt, tot cnt 

common /dndkdat/ dndata (1500, 26) ,dkdata (1500, 26) , 

> idndata (1500, 2) , idkdata (1500, 2) 
common data (3000, 26) , idata (3000, 2) 

c 

c subroutine description 

c this subroutine separates the data array into dawn and dusk data 

c sets, 

c 

data (innum+1, 1) - -90.0 
dkcnt-0 
dncnt-Q 
c 

do 200 i-1, innum 

if (data (i, 1 ) .It. data (1+1,1)) then 
dkcnt-dkcnt+1 
do 90 j-1,2 

idkdata (dkcnt, 3) -idata (i, 3) 

90 continue 

do 100 3-1,26 

dkdata (dkcnt, 3) -data {!, j) 
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100 continue 

elseif (data(i,l) .gt. data(l+l,l)) then 
dncnt-dncnt+1 

c remove the first "dawn" data point because 

c in reality this point could actually belong 

c to a dusk profile, a look at the longitudes 

c will prove this point, of course with some 

c extra code this point could be saved — but 

c hey its only one in a thousand! ! 

c 

if (dncnt .eq. 1) go to 160 
do 140 j-1,2 

idndata (dncnt-1, j) -idata (i, j) 

140 continue 

do 150 j-1,26 

dndata (dncnt-1 , j ) -data (i , j ) 

150 continue 

160 continue 

elseif (data (1,1) .eq. data (i+1, 1 ) ) then 

write (*,8880) data (i, 1 ), data (i+1, 1} , idata (i, 1) 

8880 format ('two latitudes are equal therefore program skips', 

> /, 'the first latitude ',f9.4,' and reviews the'/, 

> 'second latitude ',f9.4,* for pass number', i6) 
endif 

200 continue 
c 

totcnt - dkcnt + dncnt 

if (totcnt .ne. innum) write (*,8881) dkcnt, dncnt, totcnt, innum 

8881 format ('total dusk observations -',14,' total dawn obs. -',i4, 

> /, 'totals added -',i5, ' which differs from the input', 

> /, 'of the area selected -',15) 

c 

dncnt -dncnt-1 
return 
end 
c 
c 
c 

subroutine pfligrf (innum, idndk) 

common /dndkdat/ dndata (1500, 26) ,dkdata (1500, 26) , 

> idndata (1500,2) , idkdata (1500, 2) 

COMMON /mag fid/ THETA (1500) , PHI (1500) , ELVO(ISOO) ,YEAR(1500) 

******************************************************************* 


PROGRAM PFLIGRF 


THIS PROGRAM CALCULATES VALUES OF ALL OF THE FOLLOWING ALONG 
MAGSAT PROFILES CREATED BY STEP1P4 FORTRAN AT PURDUE. 

INDEX VALUE 

1 - pass number 

2 - TOTAL FIELD 

3 - X COMPONENT 

4 - Y COMPONENT 

5 - Z COMPONENT 

6 - INCLINATION 

7 - DECLINATION 

9 - latitude point to assure correct points are 

compared 

YEAR(I) -EPOCH IN YEARS AND DECIMAL FRACTION YEARS (E.G., 1965.75- 
1 OCT. 65) FOR WHICH THE GEOMAGNETIC REFERENCE FIELD IS TO 
BE COMPUTED AT OBSERVATION POINTS. 

THEN THE GEOMAGNETIC FIELD OVER THE OBSER- 
VATION POINT IS COMPUTED BY SUBROUTINE FIELDG FOR THE EPOCH 
SPECIFIED BY THE YEAR-INPUT VARIABLE 

TAPE UNITS: 

4. (U/I ) DATA FILES CREATED BY STEP1P4 

7. (U/O) OUTPUT. . .WATCH THE ORDER OF VARIABLES 

revised 25 AUG 90 

this subroutine was modified to read the spherical harmonic 
coefficients in the main program and transfer those coefficients 
by a common block, with these modifications, the file holding the 
coefficients is only read once and not a thousand billion times 
which decreases total run time on the program, (ok ok, so maybe 
not a thousand billion times, but only the number of dawn and 
dusk profiles given to the subroutine.) 

along the way i've removed some useless code that would write 
Items to file 6 or any of a number of additional places 
depending on which format the user supplied, so if the original 
is desired, it can be found in programs named the same as 
the subroutines in this program. 
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C' 

c 


if (idndk . eq. 1) then 
do 50 i-l,innum 

ipassl-idndata (i, 1) 
m jd-ldndata (1,2) 
secx-dndata (i, 26) 
theta (i) -dndata (1,1) 
phi (i) -dndata (1,2) 
elvo (i) -dndata (1, 3) 

ELVO(I) - ELVO (I) - 6371.2 
IDAYS - 44239 - MJD 
IF (IDAYS .GT. 0) THEN 

FRACY - FLOAT (365- (IDAYS) ) / FLOAT (365) 
F RACY A - SECX / <3600000 . *24 .* 365 . ) 
YEAR(I) - 1979.0 + FRACY + FRACYA 

FRACY - FLOAT (-IDAYS) / FLOAT (366) 
FRACYA - SECX / (3600000. *24 . *366 . ) 
YEAR(I) - 1980.0 + FRACY + FRACYA 
ENDIF 

50 continue 

eLseif (idndk .eq. 2) then 
do 70 i-l,innum 

ipassl-idkdata (i, 1 ) 
m jd-idkdata (i, 2} 
secx-dkdata (i, 26) 
theta (i) -dkdata (i, 1 ) 
phi (i) -dkdata (i, 2) 
elvo (i) -dkdata (i, 3) 

ELVO (I) - ELVO (I) - 6371.2 
IDAYS - 44239 - MJD 
IF (IDAYS .GT. 0} THEN 

FRACY - FLOAT (365- (IDAYS) ) / FLOAT (365) 
FRACYA - SECX / (3600000 . *24 .* 365 . ) 
YEAR (I ) - 1979.0 + FRACY + FRACYA 
ELSE 

FRACY - FLOAT (-IDAYS) / FLOAT (366) 
FRACYA - SECX / (3600000 . *24 . *366 . ) 
YEAR (I) - 1980.0 + FRACY + FRACYA 
ENDIF 

70 continue 

endif 

np-innum 

LQ-1 

CALL FIELDG (0.,0.,0.,0., 50, LQ, Ql , Q2, Q3, Q4 ) 

CALL GEOMAG (NP,IPASSl) 

return 

end 


SUBROUTINE GEOMAG (NPTS, IPASSl ) 

COMMON /maqfld/ THETA (1 500) , PHI (1500) , ELVO (1 500) , YEAR (1500) 
common /mainfld/ fid (1500, 8) , dawne / dawni,duske,duski,dndkpass 
INTEGER* 4 I PASSl , dndkpass 


THIS SUBROUTINE CALCULATES THE MAGNITUDE, INCLINATION, AND 
DECLINATION OF THE GEOMAGNETIC FIELD ON A GRID NTHETA BY 
NPHI 

************************************************************* 


THETA, PHI 
ELV 

HTHETA, HPHI 
NTHETA, NPHI 
NF 


** ORIGIN OF THE GRID (DEG.) 

** ELAVATION OF GRID (KILO. ABOVE SEA LEVEL) 
** GRID SPACING (DEG.) 

** DIMENSIONS OF THE GRID 

** UNIT FILE WHICH WILL STORE THE FIELD 


SUBROUTINES USED 

** FIELDG ** (NASA) 
** FIELD ** (NASA) 


LL-0 

RD-10O./3. 14159265 

DO 100 I -1, NPTS 

ATHETA - THETA (I) 

APHI - PHI (I) 

ELV - ELVO (I) 

YR - YEAR (I) 

CALL FIELDG (ATHETA, APHI, ELV, YR, 50, LL, X, Y, Z, FF) 

H-SQRT(X*X+Y*Y) 

T-SQRT (H*H+Z*Z) 
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finc-FD*ATAN2 (Z,H) 
fdec-RD*ATAN2 (Y,X) 
fld(i, l)-ipassl 
fld(i, 2)-t 
fld(i,3)-x 
fld(i,4)-y 
fld(i, 5)-z 
fld(i, 6)-finc 
fld(i, 7) -fdec 
thet-theta (i) 
fld(i, 8) -thet 
100 continue 

RETURN 

EM) 


SUBROUTINE FIELDG (DIAT, DLONG, ALT, TM, tWX, L, X, Y, Z, F) 

EQUIVALENCE (SHMIT(1,1) f TG<1,1) ) 

COMMON /NASA/ TG(50,50) 

COMMON /FLDCCM/ ST, CT, SPH # CPH, R, JMAX, BT, BP, BR, B 

common /coeff/ gg(50, 50),ggt (50, 50) ,ggtt (50, 50), jnum,knum, 

> ttzero, aaid,mmaxn, ttemp 

DIMENSION G (50, 50) , GT(50,50), SHMIT (50, 50) , GTT (50, 50) 

CHARACTER* 60 AID,aaid 
DATA A/0./ 

*******t*i******************tt*(,***** tirt<lt ,* 44)kt1>iktt<rttlkt)ktttt)t 

FOR DOCUMENTATION OF THIS SUBROUTINE AND SUBROUTINE FIELD SEE ■ 
NATIONAL SPACE SCIENCE DATA CENTER* S PUBLICATION 
* ‘COMPUTATION OF THE MAIN GEOMAGNETIC FIEID 
FROM SPHERICAL HARMONIC EXPANSIONS** 

DATA USERS’ NOTE, NSSDC 68-11, MAY 1968 
GODDARD SPACE FLIGHT CENTER, GREENBELT, MD. 

*********************************************** a.********^*^^ 

DLAT ** LATITUDE IN DEGREES POSITIVE NORTH 
DLONG ** LONGITUDE IN DEGREES POSITIVE EAST 

ALT ** ELEVATION IN KM (POSITIVE ABOVE, NEGATIVE BELOW 
EARTH'S SURFACE) 

TM ** EPOCH IN YEARS 

NMX ** SET TO INTEGER GREATER THAN DEGREE OF EXPANSION 

L ** SET TO 1 ON INITIAL DUMMY CALL, SET TO 0 ON SUBSEQUENT 
CALLS 

SUBROUTINE RETURNS GEOMAGNETIC FIELD DIRECTIONS (X,Y,2), POSI- 
TIVE NORTH, EAST AND DOWN, RESPECTIVELY, AND MAGNITUDE OF TOTAL 
FIELD, F ALL VALUES ARE IN GAMMAS 

from the data statement above, A - 0.0 only and only on the first 

call to this subroutine from anywhere within the program. after 
the first call, it is seen below that A - 6371.2 for all future 
calls during the running of the program 


TLAST-0. 0 

IF (A. EQ. 6378. 139) IF(L) 210,100,110 
IF (A. EQ. 6371 . 2 ) IF(L) 210,100,110 

A-6378.139 
A - 6371.2 
C FLAT-1. -1./298. 25 

FLAT - 1. 

A2-A**2 
A4-A**4 
B2-(A*FLAT)**2 
A2B2-A2* (l.-FIAT**2) 

A4B4-A4* (1 .-FLAT* *4) 

IF (L) 160,160,110 
100 IF (TM-TLAST) 190,210,190 
c 

110 continue 
L-0 
j- jnum 
k-knum 

tzero-ttzero 
aid-aaid 
maxn-mmaxn 
temp- ttemp 
do 120 ii-l,maxn 

do 120 iii-l,maxn 

g(ii,iii)-gg(ii,iii) 
gt (ii, iii) -ggt (ii, iii) 
gtt (ii, iii) -ggtt (ii, iii) 

120 continue 


c 110 READ (3,260) J, K, TZERO, AID 
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c L-0 

c WRITE (7,270) J,K,TZERO, AID 

c MAXN-0 

c TEMP-0. 

C 120 READ (3,280) N, M, GNM, HhW, GTNM, HTNM, GTTNM, HTTNM 
c WRITE (7, 280) N, M, GNM, HfW, GTNM, HTNM 
c IF (N.LE.O) GO TO 130 

c MAXN- (MAXO (N,MAXN) ) 

c G(N,M)-G»1 

c GT (N,M) -GTNM 

c GTT(N,M) -GTTNM 

c TEMP -AMAX1 (TEMP, ABS (GTNM)) 

C IF (M.EQ.l) GO TO 120 

c G (M-1,N) -HNM 

c GT (M-l , N ) -HTNM 

c GTT (M-l, N) -HTTNM 

c GO TO 120 

c 130 WRITE (7,290) 
c 130 CONTINUE 
c DO 150 N-2, MAXN 

c DO 150 M-l, N 

c MI -M-l 

c IF (M.EQ.l) GO TO 140 

c WRITE (7,300) N,M, G <N,M) ,G (MI, N) , GT (N, M) , GT (MI , N) , GTT (N,M) ,GTT ( 

c 1 MI , N) 

c GO TO 150 

c 140 WRITE (7,310) N, M,G (N, M) , GT (N, M) , GTT (N, M) 
c 140 CONTINUE 
c 150 CONTINUE 
c WRITE (7,320) 

IF (TEMP.EQ.O.) L— 1 
c REWIND 3 

160 IF (K.NE.O) GO TO 190 
SHMIT (1,1)— 1. 

DO 170 N-2, MAXN 

SHMIT (N, 1 ) -SHMIT (N-l , 1 ) * FLOAT (2*N-3 ) /FLOAT (N-l ) 

SHMIT (1 , N) -0. 

JJ-2 

DO 170 M-2, N 

SHMIT (N, M) -SHMIT {N, M-l) *SQRT (FLOAT ( (N-M+l ) * JJ) /FLOAT (N+M-2) ) 
SHMIT (M-l, N) -SHMIT (N, M) 

170 JJ-1 

DO 180 N-2, MAXN 
DO 180 M-l , N 

G (N, M) -G (N, M) *SHMIT (N,M) 

GT (N, M) -GT (N, M) * SHMIT (N, M) 

GTT (N,M) -GTT (N,M) * SHMIT (N,M) 

IF (M.EQ.l) GO TO 180 
G (M-l , N) -G (M-l ,N) *SHMIT (M— 1 , N) 

GT (M-l , N) -GT (M-l , N) *SHMIT (M-l, N) 

GTT (M-l, N) -GTT (M-l, N) * SHMIT (M-1,N> 

180 CONTINUE 
190 T-TM-TZERO 

DO 200 N-l, MAXN 
DO 200 M-l , N 

TG (N, M) -G (N,M) +T* (GT (N, M) +GTT (N,M) *T) 

IF (M.EQ.l) GO TO 200 

TG (M-l , N) -G (M-l , N) +T* (GT (M-l , N) +GTT (M-l , N) *T) 

200 CONTINUE 
TLAST-TM 

210 DLATR-DLAT/57 .2957795 
SINLA-SIN (DLATR) 

RLONG-D LONG/57. 2957795 
CPH-COS (RLONG) 

SPH-SIN (RLONG) 

IF (J.EQ.0) GO TO 220 
R-ALT+6371. 2 
CT-SINLA 
GO TO 230 

220 SINLA2-SINLA* * 2 
COSLA2-1 .-SINLA2 
DEN2-A2 -A2B2 * SI NLA2 
DEN-SQRT (DEN2 ) 

FAC- ( ( (ALT*DEN) +A2) / ( (ALT*DEN) +B2 ) )**2 
CT-SINLA/SQRT (FAC*COSLA2+SINLA2 ) 

R-SQRT (ALT* (ALT+2 . *DEN) + (A4-A4B4 *SINLA2 ) /DEN2) 

230 ST-SQRT (1 . -CT**2) 

NMAX -MI NO ( NMX , MAXN ) 

C 

CALL FIELD 
C 

Y-BP 

F-B 

IF (J) 240,250,240 
240 X— BT 
Z— BR 
RETURN 
C 

C TRANSFORMS FIELD TO GEODETIC DIRECTIONS 
C 
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250 SIND— SINLA* ST-SQRT (COSIA2 ) *CT 
COSD-SQRT ( 1 . 0-SIND* *2 ) 

X— BT*COSD-BR*SIND 
Z-BT* SI ND-BR*COSD 
RETURN 


C 

260 FORMAT 
270 FORMAT 
280 FORMAT 
290 FORMAT 
1 ) 

300 FORMAT 
310 FORMAT 
320 FORMAT 
C 


<2I1,1X,F6.1,A60) 

(2I3,5X,6HEP0CH , F7. 1, 5X, A60) 

(213, 6F11.4) 

(6H0 N M, 6X, 1HG, 10X, 1HH, 9X, 2HGT, 9X, 2HHT, 8X, 3HGTT, 8X, 3HHTT/ 
(2I3,6F11.4) 

(213, F11.4,11X, Fll.4, 11X,F11 .4 ) 

(///) 


END 


c 


c 


SUBROUTINE FIELD 
COMMON /NASA/ 0(50,50) 

COMON /FLDCOM/ ST, CT, SPH, CPH, R, FMAX, BT, BP, BR, B 
DIMENSION P( 50, 50), DP(50,50), CONST (50, 50) , SP(50), CP(50), 
> FN (50) , FM(50) 

DATA P(l,l)/0./ 

IF (P (1, 1) .EQ.1.0) GO TO 120 
P<1,1)-1. 

DP (1 , 1 ) -0 . 

SP (l)-0. 

CP(1)-1. 

DO 110 N-2, nmax 
FN (N)«N 
DO 110 M-1,N 
FM(M)-M-1 

110 CONST (N,M) -FLOAT ( (N-2)* *2- (M-l ) * *2 ) /FLOAT ( (2*N-3) * (2*N-5) ) 
120 SP (2) -SPH 
CP (2) -CPH 
DO 130 M-3,NMAX 

SP (M) -SP (2 ) *CP (M-l ) +CP (2) *SP (M-l ) 

130 CP (M) -CP (2) *CP (M-l)-SP (2 ) *SP (M-l) 

AOR-6371 . 2/R 
AR-AOR* * 2 
BT-0. 

BP-0. 

BR-0. 

DO 190 N-2, NMAX 
AR-AOR*AR 
DO 190 M-l, N 

IF (N-M) 150,140,150 
140 P (N, N) -ST*P (N-l , N-l ) 

DP (N, N) -ST*DP (N-l , N-l) +CT*P (N-l , N-l ) 

GO TO 160 

150 P (N, M) -CT*P (N-l, M) -CONST (N,M) *P (N-2,M) 

DP (N, M) -CT*DP (N-l , M) -ST*P (N-l ,M) -CONST (N,M) *DP (N-2, M) 

160 PAR-P (N,M) *AR 

IF (M.EQ.l) GO TO 170 

TEMP-G (N,M) *CP(M)+G (M-1,N)*SP (M) 

BP-BP- (G (N, M) *SP (M) -G (M-l, N) *CP (M) ) *FM (M) *PAR 
GO TO 180 

170 TEMP-G (N,M)*CP(M) 

BP-BP- (G(N,M) *SP (M) ) *FM (M) *PAR 
180 BT-BT+TEMP*DP (N,M) *AR 

190 BR-BR-TEMP*FN(N)*PAR 
BP-BP/ST 

B-SQRT (BT*BT+BP*BP+BR*BR) 

RETURN 

END 


subroutine corering (innum, idndk) 
integer* 4 dndkpass 

common /mainfld/ fid (1500, 8) , dawne, da wni, duske,duski, dndkpass 
common /dndkdat/ dndata (1500, 26) , dkdata (1500, 26) , 

> i dndata (1500, 2) , idkdata (1500, 2) 

common /thatsit/ outdawn (1500, 27) , outdusk (1500, 27) 
c 

subroutine description 

c this subroutine subtracts the core field at each data point and 

c calculates the ring current affect as defined by NASA's formula 

c which uses the E and I values for the entire orbit, this ring 

c current value is also subtracted to yield the ' resid'ual value, 

c since the total field value, the core-field value and the ring' 

c current values are written to file, any one value can be obtained 

c at the next processing step. 

c NOTE: the core field subtraction is not a least squares 

c procedure. the least squares removal is done in 

c program massage 
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c 


pie-3. 1415927 
radius-6371 . 2 


if (idndk . eq. 1} then 
do 100 i-l,innum 

if (dndata U,l) .ne. fld(i,8)) then 

write <*,*) 'no match between latitudes in corering', 

> 1 subroutine with dawn dataset' 
write (*,*) dndata (i, 1) , fld(i, 8) 

stop 

elseif (dndkpass . ne . idndata (i, 1 ) .or. dndkpass. ne.f id (i, 1 ) 

> .or. idndata(i,l) ,ne.fld(i, 1) ) then 

write (*,*) ‘no match between pass numbers in corering', 

> * subroutine with dawn dataset' 
write (*,*) dndkpass, idndata (i, 1) , fid (i, 1) 
stop 

endif 


c 


> 

> 


> 


150 

170 


100 


totmag-dndata (i, 8) -fid (i, 2) 
tavgmag-dndata <i, 12)-fld(i, 2) 
dip-dndata (i, 6)* (pie/180.0) 
delbzz- (dawne*sin (dip) ) - (2 .0*dawni*sin (dip) * 

{ (radius/dndata (i, 3) ) **3.0) ) 
delbxx- (-1 . 0*dawne*cos (dip) ) - (dawni*cos (dip) * 

( (radius/dndata <i, 3) ) **3.0) ) 

ringcur- (sqrt ( ( (f ld(i, 3) +delbxx) **2.0) + (fld(i, 4) **2.0) + 
( (fid (i, 5) +delbzz) **2 . 0) ) ) - fld(i,2) 
resid-totmag-ringcur 
re sav gmag-tavgmag-ringcur 
do 150 j-1,15 

outdawn (i, j) -dndata (i, j) 
continue 
do 170 j— 16, 21 
jj-j-14 

outdawn (i, j) -fld(i, j j) 
continue 

outdawn (i, 22 ) -totmag 
outdawn (i, 23) -tavgmag 
outdawn (i, 24 ) -resid 
outdawn (i, 25) -resavgmag 
outdawn (i, 26) -ringcur 
outdawn (i, 27) -dndata (i, 26) 
continue 


elseif (idndk .eq. 2) then 
do 200 i-l,innum 

if (dkdata <i , 1 ) .ne. fld(i,8>) then 

write (*,*) 'no match between latitudes in corering 1 , 

> * subroutine with dusk dataset' 
write (*,*) dkdata (i, 1 ) , fid (i, 8) 

stop 

elseif (dndkpass. ne. idkdata (i, 1) .or. dndkpass. ne .fid (i, 1) 

> .or. idkdata (i, 1} .ne. fld(i, 1 ) ) then 

write (*,*) 'no match between pass numbers in corering', 

> ' subroutine with dusk dataset' 
write (*,*) dndkpass, idkdata (i, 1) , fid (i, 1) 
stop 

endif 


totmag- dkdata (i, 8) -fld(i, 2) 
tavgmag-dkdata (i, 12)-fld (i, 2) 
dip-dkdata (i, 6) * (pie/180.0) 

delbzz- (duske*sin (dip) ) - (2 . 0*duski*sin (dip) * 

> ( (radius/dkdata(i, 3) ) **3.0) ) 
delbxx- (-1 .0*duske*cos (dip) )- (duski*cos (dip) * 

> ( (radius/dkdata (i, 3) ) **3.0} ) 

ringcur- (sqrt (( (fld(i, 3) +delbxx) **2.0) + (f Id (i, 4 ) **2. 0) + 

> ( (fid (i, 5) +delbzz) **2.0))) - fld(i,2) 
resid-totmag-ringcur 
resavgmag-tavgmag-ringcur 

do 250 j-1,15 

outdusk (i, j) -dkdata (i, j) 

250 continue 

do 270 j-16,21 
jj-j-14 

outdusk(i, j) -fid (i, jj) 

270 continue 

outdusk (i, 22) -totmag 
outdusk (i, 23) -tavgmag 
outdusk (i, 24 ) -resid 
outdusk (i, 25) -resavgmag 
outdusk (i, 26) -ringcur 
outdusk (i, 27) -dkdata (i, 26) 

200 continue 

endif 
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return 

end 

c 

c this is the driver for direct access 

c 

c program sub core 

c realM rbuff (3024/4) ,minlat ,maxlat, minion, maxlon, 

c > seconds (3000) 

c integer*4 ibuff (3024/4) , flagl, flag2, headcnt, recnum, 

c > outnum, dnnum, dknum, 

c > dndXpass, datacnt, stoplO, stopll, 

c > headlO, datalO, headll, datall,headl2, datal2, totrecord, 

c > dnr«c,dJcrec, nowant (50) 

c character* 80 filename 

c character*4 cbuff (3024/4) 

c character*60 aaid 

c equivalence (ibuff, rbuff ), (cbuff, rbuff ) , (flagl, ibuff (1 )) , 

c > (flag2, ibuff (2) ) 

c cornnon /latlon/ minlat,maxlat, minion, maxlon 

c cornnon /dndkdat/ dndata (1500, 26) , dkdata (1500, 26) , 

c > idndata (1500, 2 ) , idkdata (1500, 2) 

c common /coeff/ gg (50, 50) , ggt (50, 50) , ggtt (50, 50) , jnum, knum, 

c > tt zero, aaid, mmaxn, ttemp 

c common /mainfld/ fld(1500,8) ,dawne,dawni,duske,duski,dndkpass 

c conmon /thatsit/ outdawn (1500, 27) , outdusk (1500, 27) 

c COW-ION /NASA/ TG(50, 50) 

c C0M4ON /FLDCOM/ ST, CT, SPH, CPH, R, NMAX, BT, BP, BR, B 

c COMMON /magfld/ THETA (1500) , PHI (150(3) , ELVO (1500) , YEAR (1500) 

c common data (3000, 26} , idata (3000, 2 ) 

cc 

c write (*,*) 'INPUT FIRST DATASET FROM TAPE TO DISC TRANSFER' 

c read (*,9990) filename 

c 9990 format (a80) 

c open (10, file-filename, status- 'old' , form- ' unformatted* , 

c > access- 'DIRECT' , recl-3024/4) 

c write {*,*) 'INPUT SECOND DATASET FROM TAPE TO DISC TRANSFER' 

c read (*,9990) filename 

c open (11, file-filename, status- 'old' , form-' unformatted' , 

c > access-'DIRECT' , recl-3024/4) 

c write (*,*) 'INPUT THIRD DATASET FROM TAPE TO DISC TRANSFER' 

c read (*,9990) filename 

c open (12, file-filename, status-'old' , form- 'unformatted' , 

c > access-’DIRECT' , recl-3024/4 ) 

c write (*,*) 'INPUT FIELD MODEL SPHERICAL HARMONIC' 

c write (*,*) 'COEFFICIENTS (GSFC1283) ' 

c read (*,9990) filename 

c open (13, file-filename, status- ' old' , form- ' formatted' ) 

cc 

cc use the following if you want to input 

cc your own file of nowant passes 

cc write (*,*) '1 to remove certain pass numbers' 

cc write (*,*) ' 0 do no remove any pass numbers' 

cc read (*,*) nocnt 

cc if (nocnt .ne. 0) then 

cc write (*,*) 'input file of pass numbers not wanted* 

cc read (*,9990) filename 

cc open (14, file-filename, status-' old' , form-' formatted' ) 

cc do i-1,5000 

cc read (14 ,*, end-10) nowant (i) 

cc enddo 

cc 10 nocnt -i-1 

cc endif 

cc the following lines automatically place the nowant 

cc pass numbers in the nowant array, these passes are 

cc messed up for one reason or another. I'm sure they 

cc could be salvaged, but i'm lazy, 

c nowant (1) -909 

c nowant (2) -1079 

c nowant (3) -1206 

c nowant (4 ) -2602 

c nowant (5) -2728 

c nowant (6) -2744 

c nowant (7) -2791 

c nowant (8) -2854 

c nowant (9) -3059 

c nocnt-9 

c recl-116 for an ibm rs6000 

c 

c write (*,*) 'OUTPUT DAWN DATA FILE OF 2-INTEGERS AND 27-REALS' 

c read (*,9990) filename 

c open (20, file-filename, form-' unformatted' , access- ' DIRECT' , 

c > recl-29) 

c write (*,*) 'OUTPUT DUSK DATA FILE OF 2-1 AND 27-R* 

c read (*,9990) filename 

c open (21, file-filename, form-' unformatted* , access- ' DIRECT' , 
c > recl-29) 

c write (*,*) 'OUTPUT HEADERS FILE* 

c read (*,9990) filename 

c open (22, file-filename, form- ' formatted' ) 

cc 
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c write (*,*) *0 FOR NO ADDITIONAL INFORMATION* 

c write (*,*) *1 FOR ONLY Dst INDEXES' 

c write {*,*) *2 FOR COMPLETE INFORMATION... this is a bio file* 

c read (*,*) info 

c if (info .gt. 0 } then 

c write (*,*) 'OUTPUT ADDITIONAL INFORMATION ORBIT FILE' 

c read {*,9990) filename 

c open (23, file-filename, form-' formatted' ) 

c endif 

cc 

C write (*,*) 'MINIMUM AND MAXIMUM LATITUDE OF STUDY AREA' 

c write (*,*) 'INPUT RANGE IS FROM -90.0 TO 90.0* 

c read (*,*) minlat,maxlat 

c write (*,*) 'MINIMUM AND hAXIMUM LONGITUDE OF STUDY AREA' 

c write (*,*) 'INPUT RANGE IS FROM -180.0 TO 180.0' 

c read {*,*) minion, maxlon 

cc 

cc the following arrays store the spherical 

cc harmonic coefficients that describe the 

cc core field 

c READ (13,9926) Jnum,Knum,TtZERO, AalD 

c 9926 FORMAT (211, IX, F6.1, A60) 

c MnAXN-0 

C TtEMP-0. 

C 50 READ (13,9928) N, M, GNM, HNM, GTNM, HTNM, GTTNM, HTTNM 

c 9928 FORMAT (213, 6F11.4) 

c IF (N.LE.0) GO TO 80 

C MnAXN- (MAX0 (N, MnAXN) ) 

c Gg(N,M) -GNM 

c GgT (N, M) -GThM 

c GgTT(N,M) -GTTNM 

c TtEMP-AMAXl (TtEMP, ABS (GThW) ) 

c IF (M.EQ.l) GO TO 50 

c Gg (M-l, N) -HtW 

c GgT (M-1,N) -HTNM 

c GgTT (M-l , N) -HTTNM 

c GO TO 50 

c 80 CONTINUE 
cc 

c dnrec -0 

c dJurec -0 

c tot re cord - 0 

c datacnt -0 

c headcnt -0 

c s topi 0-0 

c stopll -0 

cc 

c headlO-O 

c datalO-O 

c recnum -1 

cc 

c 100 num -1 

c 110 read ( 10 , rec-recnum,err- 120 ) rbuff 
c go to 220 

cc 

c 120 stopl 0 -l 

c write (*,*) 'done with file one' 

c write (*,*) 'total headers on file one -',headl 0 

c write (*,*) 'total data sets on file one -\datal 0 

c headll -0 

c datall -0 

c totrecord-totrecord+recnum 

c recnum -1 

cc use the go to 999 statement if you only 

cc . want to input one file at a time 

c go to 999 

c 125 num-1 

c 130 read (11 , rec-recnum,err-150) rbuff 
c go to 220 

cc 

c 150 s topi 1-1 

c write (*,*) 'done with file two* 

c write (*,*) 'total headers on file two -',headll 

c write (*,*) 'total data sets on file two -' datall 

c headl 2-0 

c datal 2-0 

c totrecord-totrecord+recnum 
c recnum -1 

c 155 num -1 

c 160 read (12,rec-recnum,err-999) rbuff 
cc 

c 220 continue 


cc 

c if 

c 

c 

c 

C 

C 

c 


■ 7 """; 77 — if flagl -1 then this is header file 

(flagl .eq. 1 ) then 
if (info .eq. 0 ) then 
go to 225 

elseif (info .eq. 1 ) then 

write (23,*) ibuf f (4) , (rbuf f (i) , i-23, 34 ) 
elseif (info .eq. 2 ) then 

write (23,*) (ibuf f (i ) , i-1 , 4 ) , (rbuf f (i ) , i-5, 8) , 
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C > (ibuff (i) , i-9, 10) , (rbuff (i) ,1-11, 14) , 

c > (ibuff (i),i-15, 16), (rbuff (i) ,1-17,34), 

c > (cbuf f (i) , i-35, 64 ) , (ibuff (i),i-65, 67), 

c > (rbuff (i), 1-68, 557) 

c endlf 

c 225 continue 

c write (22,8880) ibuff (4 ), (rbuff (i) , i-5, 8) , (ibuff (i) , i-15, 16) 

c 8880 format (Ix,i5,4el5.7, 216) 
c dndkpass- ibuff (4 ) 

c duske-rbuff (5) 

c duski-rbuff (6) 

c dawne- rbuff (7) 

c dawni-rbuff (8) 

c headcnt-headcnt+1 

c recnum-recnum+1 

c if (stoplO .eq. 0 .and. stopll ,eq. 0) then 

c headlO-heaalO+l 

c go to 100 

c elseif (stoplO ,eq. 1 .and. stopll .eq. 0) then 

c headll-headll+1 

c go to 125 

c elseif (stoplO .eq .1 .and. stopll .eq. 1) then 

c head!2-headl2+l 

c go to 155 

c endlf 

cc if flagl-2 then this is a data file 

c elseif (flagl .eq. 2) then 

c do 230 i-nura, num+29 

c idata (i, 1 ) -ibuff (5) 

c idata (i, 2) -ibuff (3) 

c xnum-real (i-num) 

c seconds (1)- (real (ibuff (4) ) + (rbuf f (6) *xnum) ) 

c 230 continue 

cc these do 250 loops reorder the data 

cc from column to row oriented data 

c jj-7 

c do 250 1-1,25 

c do 250 i-num, num+29 

c data (i, j) -rbuf f (jj) 

c jj-jj+l 

c 250 continue 

cc 

c num-num+30 

cc 

cc if flag2-l then the next record is 

cc a header and the data information is 

cc complete for this orbit 

c if (flagl .eq. 2 .and. flag2 .eq. 1) then 

c innum-num-1 

cc 


cc 

cc 

cc 

cc 

cc 

cc 


c 

c 

c 

c 

c 

c 

cc 

c 

c 

c 270 


c 

cc 


c 300 
c 310 


cc 

c 

c 

c 

c 

c 

c 


search the nowant array for passes 

that just didn't happen, the 
following passes are doubled and 
are considered not wanted: 

909, 1079, 1206, 2602, 2728, 2744, 2791, 
2854,3059 

do i-l,nocnt 

if (nowant (i) .eq. idata(l,l)) then 
write {*,*) 'removed pass number ', 
nowant (i ) , idata (1,1) 

go to 400 
endlf 
enddo 

do 270 i-l,innum 

data (i, 26} -seconds (i ) 
continue 

call nine (innum, outnirn) 

innum-outnum 

call area (innum, outnum) 

innum-outnum 

call dawndusk (innum, dnnum, dknum) 

if (dnnum .le. 0) go to 310 
call pfligrf (dnnum, 1) 
call corering (dnnum, 1) 
do 300 i-1, dnnum 
dnrec-dnrec+1 

write (20, rec-dnrec) (idndata (i, j) , j-1, 2> , 

(outdawn (i, j) , j-1, 27) 

continue 

continue 

if (dknum .le. 0) go to 360 
call pfligrf (dknum, 2) 
call corering (dknum, 2) 
do 350 i-1, dknum 
dkrec-dkrec+1 

write (21, rec-dkrec) (idkdata (i, j) , j-1, 2) , 
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> 


(outdusk (1, j) , j-1,27) 


c 350 continue 

c 360 continue 

c endif 

cc 

c 400 recnuin-recnum+1 

c datacnt-datacnt+1 

c if (stoplO .eq. 0 .and. stopll .eq. 0) then 

c datalO-datalO+1 

c go to 110 

c el*eif {stoplO .eq. 1 .and. stopll .eq. 0) then 

c datall-datall+1 

c go to 130 

c elseif {stoplO .eq .1 .and. stopll .eq. 1) then 

c datal2-datal2+l 

c go to 160 

c endif 

cc 

c elseif (flagl .ne. 1 .or. flagl ,ne. 2) then 

C write (*,*} * HOLD THE FORT MAN, BAD FIRST FLAG NUMBER* 

C write {*,*) flagl 

c go to 999 

c endif 

cc 

c 999 continue 

c write {*,*) ‘total headers on file three -',headl2 

c write {*,*) ‘total data sets on file three -*,datal2 

c write (*,*) 'total headers on tapes -',headcnt 

c write {*,*) 'total data sets on tapes -',datacnt 

c totrecord-totrecord+recnuro 

c write {*,*) 'total records read - ' , totrecord 

c write {*,*) 'total records written to dawn file -',dnrec 

c write {*,*) ’total records written to dusk file «',dkrec 

c close {10) 

c close {11) 

c close (12) 

c close (13) 

c close (14) 

c close (20) 

c close (21) 

c close (22) 

c close (23) 

c stop 

c end 

cc 

cc add on all subroutines from here on 
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program reorder 
character*80 filename 

integer passm jd (4000, 2) , idata (400, 2) , istore (2) , 

> countall, jstop, choice, passno (4000) , dndk, 

> pntcnt (4000,2) , shrtpas (3000, 2) , shrtcnt, 

> passrec (4000, 2), passrem, enter, denum,pchoice, 

> spknum,mincheck, spkvar, nowant (4000) ,outnam, 

> minchk, entsome, inrec, innum, outrec, oif , inf ,onf, 

> innumall,pntall (4000, 2) 

real data (400, 27) ,dstore (27) , east, west, diffwe, hilat, 

> lolat, north, south, percent, totlat, upper , lower, 

> desdata (400,27) , intpdata (400,27) 

double precision aver (4000, 2 ), ra (4000) , cross, passavg (4000, 2) , 

> savglon(4000, 2) ,crosss 
common data (400, 27) , idata (400, 2) 

common /orderl/ aver (4000, 2) , passm jd(4000, 2 ), cross 
common /order2/ passno(4000) , pntcnt (4000, 2) ,pntall (4000,2) 
common /order3/ savglon (4000, 2) , crosss 
common /hsort/ ra(4000) 

common /shorty/ shrtpas (3000, 2) , shrtcnt, passrec (4000, 2) 
common /spike/ desdata (400, 27 ), upper, lower, spkvar 
common /intb/ intpdata (400, 27) 

program description 

this program takes data in the 2-integers and 27-reals format 
and reorders the entire dataset into a sorted file according 
to the variable that the user chooses, that variable is usually 
the average longitude of each individual pass, such that after 
reordering, the dataset will have all passes arranged from LOWEST 
average longitude (-179.99) to the HIGHEST average longitude 
(+179.99). if the dataset crosses the -180.0 180.0 meridian, 
then the eastern (negative) longitudes are incremented to a 
positive value by adding 360.0 (see write statement with 
variable "cross") . the sorting variable can also be the 
average elevation or the pass numbers of each individual pass 
(sorting by pass numbers - sorting by time), this program takes 
a little time (about 15 minutes on the DECstatlon 3100). the 
program requires DIRECT ACCESS or else it Just won't happen! 

NOTE: as crazy as it may seem, real*8 is necessary for the 

averages because i found two dusk longitude averages to be 
EXACTLY the same with real*4. if two averages are the same 
then passno(4000) will have the same pass twice which messes 
up subroutine reorder2. 

NOTE: i usually try to keep all file reads and writes in the 

main program but reorder2 and reorder3 are a deviation 
from the rule 

NOTE: the dataset must be despiked and interpolated to 

correctly calculate the longitude averages of the 
extended passes, however, i prefer to not write out 
the despiked or interpolated data because this program 
represents the end of the first processing step, after- 
which the data is ready for more involved processing 
(ie. correlation filtering, bandpassing ...). 
therefore, the output from reorder should be the 
original data, only reordered, get it?? 

NOTE: for direct access on an ibm rsfiOOO, recl-116. 

on a dec3100, recl-29 

program date: 16 apr 91 

write (*,*) 'INPUT 2I-27R FILE:' 
read (*,9990) filename 
format (a80) 

open (10, file-filename, status- 'old' , form- ' unformatted' , 

> access-'dlrect' , recl-116) 

write (*,*) '0 IF THIS IS A DUSK DATASET* 

write (*,*) '1 IF THIS IS A DAWN DATASET' 

read (*,*) dndk 

write {*,*) '1 TO AVERAGE AND REORDER ON LONGITUDE' 

write {*,*) '2 TO AVERAGE AND REORDER ELEVATION' 

write (*,*} '3 TO REORDER ON PASS NUMBER' 

read (*,*) choice 

if (choice .eq. 1) then 

write (*,*) 'OUTPUT FILE OF 2I-27R DATASET REORDERED* 
read (*,9990) filename 

open (20, file-filename, form-' unformatted ', access-' DIRECT' . 

> recl-116) 

write (*,*) 'INTERMEDIATE 1/0 FILE NOT REORDERED' 

write (*,*) ' DO NOT USE THIS FILE ' 

read (*,9990) filename 

open (21, file-filename, form- 'unformatted' , access-' direct' 

> recl-116) 
endif 

if (choice .gt. 1) then 

write (*,*) 'OUTPUT FILE OF 2I-27R DATASET REORDERED' 
read (*,9990) filename 

open ( 20 , file-filename, form- ' unformatted' , access-'dlrect 1 , 

> recl-116) 
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endif 

write (*,*} 'OUTPUT FILE OF PASS NUMBERS AND AVERAGED 1 , 

> ' SORTED VARIABLE' 

read (*,9990) filename 

open (22, file-filename, form-' formatted' ) 

write <*,*> '0 IF YOU WANT ALL PASSES* 
write <*,*) *1 IF S0*C PASSES NEED TO BE REMOVED' 
read (*,*) pchoice 
if (pchoice . eq. 1) then 

write (*,*) 'INPUT FILE OF PASSES YOU DO NOT WANT' 
read (*,9990) filename 

open (11, file-filename, form-* formatted' ) 
endif 

write (*,*) 'WHAT IS THE MINIMUM NUMBER OF' 

write (*,*) 'OBSERVATIONS ALLOWABLE FOR EACH PASS (50)' 

read (*,*) mincheck 

write (*,*) *0 FOR NO DESPIKING OF DATA SET' 
write (*,*) *1 FOR DESPIKING ONCE' 

write (*,*) '2 FOR DESPIKING WICE (this i« the ueual choice)' 
write (*,*> '3 ... AND SO ON' 
read (*,*) spknum 
if (spknum .gt. 0) then 

write (*,*) 'WHAT IS THE MAXIMUM nT: (1.0)' 
write (*,*) 'WHAT IS THE MINIMUM nT: (-1.0)' 
read (*,*) upper, lower 

write (*,*) 'WHICH VARIABLE TO DESPIKE: (23)' 
write (*,*) ' 1-LAT, 2-LONG, .. ,23-totavgmag. . 25-resavgmag. .. ' 
write (*,*) ‘lat Ion rad mlt invlat diplat bs bv x y z* 
write {*,*) 'bva xa ya z a totfld xfld yfld zfld inc dec' 
write (*,*) 'totmag totavgmag resid resavgmag ringcur sec ' 
read (*,*) spkvar 
endif 


c the following if statement determines if 

c the study area includes the -180.0 180.0 

c longitude line, for further comments see 

c subroutine reorderl 


cross-0.0 

crosss-cross 

minchk-0 

if (choice .eq. 1) then 

write (*,*) 'WESTERN MOST LONGITUDE OF STUDY AREA* 
write (*,*) 'EASTERN MOST LONGITUDE OF STUDY AREA' 
write (*,*) '-180.0 to 180.0 NOT 0.0 to 360.0' 
read (*,*) west, east 
diffwe - west - east 
if (diffwe .gt. 0.0) then 
cross-360. 0 
crosss-cross 
write (*,*) ' ' 

write (*,*} 'the program has determined that this study' 
write (*,*) 'area crosses the 180.0, -100.0 meridian* 
write (*,*) ' ' 
endif 

write (*,*) 'NORTHERN AND SOUTHERN MOST LATITUDES' 
write (*,*) '90.0 to -90.0 NOT 0.0 to 180.0' 
read (*,*) north, south 

write (*,*) 'PERCENT OF TOTAL LATITUDE LENGTH TO' 

write (*,*) 'TO BE CONSIDERED TO FIND SHORT PASSES (90.0)' 

read (*,*) percent 


c percent is used to calculate the range that 

c is used in subroutine shorts to determine 

c if a pass is a short pass or a long pass, 

c see shorts for more info, also, since no 

c passes go below or above 03.0 degrees, the 

c program resets north and south if needed. 


if (north .gt. 83.0) north - 03.0 
if (south .It. -83.0) south - -03.0 
totlat-abs (north-south) 

minchk- (int ( ( (100.0-percent)/ (2*100.0)) * tot lat) +1 ) *3 
percent- ( (100.0-percent) / (2*100 . 0) ) *totlat 
lolat-south+percent 
hilat -north-percent 
endif 

if (minchk .gt. mincheck) then 
mlncheck-minchk 

write (*,*) 'minimum observation cut-off increased to', 
> ' -', mincheck 

endif 

if (pchoice .eq. 1} then 
do 50 kk-1,4000 

read (11, *, end-55) nowant (kk) 

50 continue 

55 continue 

pchoice-kk-1 

endif 
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c the main program reads the data to find 

c which 2i-27r lines belong to a specific pass 

c number (idata(n,l)) and since it reads one line 

c of the next pass it stores that line in 

c memory, 

c 


inrec-1 

outrec-0 

shrtcnt-0 

countall-0 

jstop-0 

passrem-0 

cntscme-0 

c 

read (10, rec-inrec) (idata (1, i) , 1-1 , 2) , (data (1 , j) , j-1, 27) 

100 n-2 

105 inrec-inrec+1 

read (10, rec-inrec, err-110) (idata (n, i) , i-1 , 2) , (data (n, j) , j-1, 27) 
if (idata (n,l) .ne. idata (n-1, 1 ) ) go to 120 
n-n+1 
go to 105 
110 continue 
jstop-1 
120 continue 

do 130 1-1,2 

is tore (i) -idata (n, i) 

130 continue 

do 140 i-1, 27 
dstore (i) -data (n, 1} 

140 continue 
c 

countall-countall+1 

innum-n-1 

lnnumall-innum 

c 

c if passes are NOT wanted, remove them 

if (pchoice .eq. 0) go to 145 
do 143 ii-1, pchoice 

if (idata (innum, 1 ) .eq. nowant (ii) } then 

write (*,*) 'PASS NUMBER REMOVED \ nowant (ii ) , 

> idata (innum, 1 ) 

passrem-passremt 1 
go to 400 
endif 

143 continue 
145 continue 
c 

if (innum .It. mincheck) then 

write (*, 9980) idata (innum, 1 ), innum 


9980 format ('PASS REMOVED AT READ -',16,' OBSERV COUNT -',15) 
passrem-passrem+1 
go to 400 
endif 

c search for passes that cross from 

c -180.0 to 180.0 meridian 

imerpass-idata (1,1) 
call meridian (innum, imer pass) 

c despike the data if user chooses and 

c despike the number of times chosen 


if (spknum .eq. 0) go to 190 
cnter-0 

150 call despike (innum, denum) 
cnter-cnter+1 
innum-denum 
do 180 k-1, innum 
do 180 kk-1,27 

data (k, kk) -desdata (k, kk) 

180 continue 

if (enter .It. spknum) go to 150 
c 

190 continue 

if (innum .It. mincheck) then 

write (*,9981) idata (innum, 1 ), innum 
9981 format (’PASS REMOVED AFTER DESPIKING -',i6, 

> ' OBSERV COUNT -*,i5) 
passrem-passrem+1 

go to 400 
endif 
c 

Interpolate the dataset 

call interpl (dndk, innum, outnum) 
innum -outnum 
do 210 i-1, innum 
do 210 j-1, 27 

data (i, j) -intpdata (i, j) 

210 continue 

if (innum .It. mincheck) then 

write (*,9982) idata (1 , 1 ), innum 
9902 format ('PASS REMOVED AFTER INTERPOLATING -*,i6, 

> ' OBSERV COUNT -',15) 
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passrem-passrem+1 
co to 400 
endif 

if (choice „eq. 1) oif-21 
if (choice ,gt. 1) go to 260 
do 250 i-l,innum 
outrec-outrec+1 

write (oif, rec-outrec) (idata (1 , j) , j-1, 2) , (data (i, j) , j-1, 27) 

250 continue 

260 continue 

cntsome-cntsome+1 
pntcnt (cntscme, 2 } -inn urn 
pntcnt {cntscme, 1) -idata (1, 1) 
pntall (cntscme, 1 ) -idata (1,1) 
pntall (cntscme, 2) -inn umall 

: subroutine finds all short passes 

if (choice .eq. 1) call shorts (innum, hilat, lolat,dndk) 


c 

c 

c 

c 

c 

c 

call reorderl (innum, cntsome) 

c 

c 

400 continue 

do 410 1-1,2 

idata (1, i) -istore (i) 

410 continue 

do 420 i-1,27 

data (1, i) -dstore (i) 

420 continue 

if (jstop .eq. 1) go to 500 
go to 100 
c 

500 continue 


now call reorderl which will find 
the average longitude and elevation 
(not radius) and store them in 
aver (4000) as well as storing the 
pass number and modified julian day for 
the current pass. 

ok, now go back and get more passes 
to average until done with the file 


: now sort the chosen variable 

call sort (cntsome, choice) 

do 550 1-1, cntscme 
do 530 j-1, cntsome 

if (choice .eq. 1) then 

if (aver (j, choice) .eq. ra(i)) then 
passno (i } -passm jd ( j, 1 } 
passavg (i, 1 ) -dble (passmjd( j, 1) ) 
passavg (i, 2) -aver ( j, choice) 
write (22,*) (passmjd( j, ii ) , ii-1, 2) , 

> (aver ( j,ii) , ii-1, 2) 
go to 540 

endif 

elseif (choice .eq. 2) then 

if (aver (j, choice) .eq. ra(i)) then 
write (22,*) (passm jd(j, ii) , ii-1, 2) , 

> (aver ( j, ii) , ii-1, 2) 
passno (1) -passm jd( j, 1) 

go to 540 
endif 

elseif (choice .eq. 3) then 

if (passmjd( j, 1) .eq. int(ra(i))) then 
write (22,*) (passm jd(j, ii) , ii-1, 2) , 

> (aver ( j, ii) , ii-1 , 2) 
passno (i ) -passm jd( j, 1 ) 

go to 540 
endif 
endif 

530 continue 

540 continue 

550 continue 


c 


c now reread the file in reorder 2 and write 

c it ordered according to the pass numbers 

c given to reorder2 . 

c 

if (choice .eq. 1) then 
inf-21 
onf-20 

elseif (choice ,gt. 1) then 
inf-10 
onf-20 

endif 

call reorder2 (cntsome, inf , onf) 
c 

c if sorting by average longitude, then must 
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c extend the shorter passes and calculate a 

c new average, see subroutine reorder3 for 

c more information, 

c 

if (choice .eq. 1) then 
c 


call reorder3 (cntscme, dndk) 

do 600 i-1, cntsome 
do 610 j-l,shrtcnt 

if (savglon ( j, 1) .eq. passavg (i, 1 ) ) then 
passavg (i, 2) -savglon ( j, 2) 
go to 620 



endif 

610 

continue 

620 

continue 


ra (i ) -passavg (i, 2) 

600 

continue 


c 


c 


655 

656 


650 

660 

640 


680 

c 

c 

c 

999 


call sort (cntsome,4) 
write (22,*) 1 * 

write (22,*) 'new reordering as follows 1 
write (22,*) * • 
do 640 i-1, cntscme 
do 650 j-l,cntaome 

if (ra (i) .eq. passavg ( j, 2) ) then 
passno (i) -int (passavg ( j, 1 ) ) 
do 655 k-l,cntsome 

if (passno (i) .eq. passm jd(k, 1 ) ) then 
i22m jd-passm jd(k, 2) 
x22elev-aver (k, 2 ) 
go to 656 
endif 
continue 
continue 

write (22,*) int (passavg ( j, 1 )), i22mjd, 
passavg ( j, 2) , x22elev 

go to 660 
endif 
continue 
continue 
continue 

write (22,*) 1 • 

write (22,*) shrtcnt, ' short passes as follows' 
write (22,*) 1 * 

do 600 i-1, shrtcnt 

write (22,*) (shrtpas (i, j) , j-1 , 2) 
continue 

call reorder 2 (cntsome, 10, 20) 


endif 



continue 


write 

<*,*) 

• total 

write 

(*,*) 

' total 

write 

<*,*) 

'total 

write 

(*,*) 

' total 

write 

(*,*) 

' total 

close 

(10) 


close 

(20) 


close 

(21) 


close 

(22) 


close 

stop 

end 

(25) 



passes read -',countall 

passes written cntsome 

passes removed -',passrem 

passes considered to be short shrtcnt 

records read for original input file- ' , inrec-1 


c 

c 

c 

subroutine meridian (innum, passnum) 
real data (400, 27) 

integer idata (400, 2) , innum, passnum 
common data (400, 27) , idata (400, 2) 
c 

do 100 i-1, innum-1 

if (data (i, 2) .It. data(i+l,2)> then 

write (*,*) passnum,' CROSSES “180.0', data (1,2), data (i + 1, 2) 
do 150 ii-1, innum ' 

if (data (ii, 2) .It. 0.0) data (ii, 2) -data (ii, 2) +360.0 
150 continue 

go to 200 
endif 
100 continue 


c 

200 continue 
return 
end 


c 

c 
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c 


c 

c- 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


50 

c 


110 

120 

130 

135 

150 

170 


c 

200 


c 

c 

c 


subroutine reorderl (nobs,nura) 
real data (400, 27) 

double precision nobss, along (4000) , radd (4000), aalong, aavg, se lev, 

> elev (4000) , savg, aver (4000, 2) , cross 
integer nobs, num, idata (400, 2) ,passm jd (4000, 2) ,mjd, 

> pass num 

common /orderl/ aver (4000, 2) , passmjd (4000, 2) , cross 
common data (400, 27) , idata (400, 2) 

subroutine description 

reorderl takes a given set of longitudes and elevations and 
finds the average longitude and elevation for the set. since 
sane longitudes cross FROM -180.0 TO +180.0 (that Is, longitudes 
always decrease unless crossing 180) it necessary to correct 
the average to the more usual 360 method, therefore the 
dataset is ordered fran westernmost longitude to eastern most. 
NOTE: real* 8 is necessary since on some rare occasions the 
averages can be the same at real* 4 precision. 

NOTE: when the study area includes the -180.0 180.0 longitude 
line (but does not include all other longitudes) it is 
necessary to add 360.0 to the negative (or eastern) 
longitudes so that eastern longitudes will be located after 
the western longitudes. 

NOTE: for datasets that are global (ie. polar datasets or the 

whole blasted world) then variable 'west* should be input 
as -180.0 and variable 'east' should be input as 180.0. 
input as such will produce a map centered on 0.0 
longitude. 

nobss-dble (nobs) 
passnum-idata (1,1) 
mjd-idata (1,2) 
do 50 n-1 , nobs 

along (n) -dble (data (n, 2) ) 
radd(n) -dble (data (n, 3) ) 
continue 

aalong-0.0 
do 110 n-l,nobs-l 

if (along (n) .It. along (n+1)) then 

write (*,*) passnum, ' CROSSES -180.0 to 180.0', 

> along (n) , along (n+1) 
go to 130 

endif 
continue 
do 120 n-1, nobs 

aalong-aalong+along (n) 
continue 

aavg-aalong/nobss 
go to 150 

aalong-0.0 
do 135 n-1, nobs 

if (along (n) .It. 0.0) then 
along (n) -along (n) +360.0 
endif 

aalong-aalong+along (n) 
continue 

aavg-aalong/nobss 

continue 
selev-0. 0 
do 170 n-1, nobs 

elev (n) -radd(n) -6378. 140 
selev-selev+elev (n) 
continue 

sa vg- se 1 ev /n obs s 

if (aavg ,gt. 180.0) aavg-aavg-360 . 0 

pas sm jd { num , 1 ) -pas s num 

passmjd (num, 2 ) -m jd 

aver (num, 1) -aavg + cross 

aver (num, 2) -savg 

continue 

return 

end 


subroutine reorder2 (nlines, inf, onf ) 

integer nrecord (4000) , passno (4000) , npoints (4000) , 

> idata (2 ) , pntent (4000, 2) , passrec (4000, 2) , 

> shrtpas (3000,2) , shrtent, inrec2, inf, onf, 

> pntall (4000, 2) 
real data (27) 

common /order2/ passno (4000) , pntent (4000, 2) , pntall (4000, 2) 
common /shorty/ shrtpas (3000, 2) , shrtent, passrec (4000, 2) 
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c 

c the basis for this subroutine was provided 

c quite generously 

c by: Dr, D.R.H. O’Connell 

c Dept, of Geologcial Sci. 

c Ohio State University 

c 
c 

c determine which pass this point belongs to. 

c 


if (inf .eq. 10) then 
do 20 1-1, nlines 

passrec (i, 1 )-passno (i ) 
do 30 li-1, nlines 

If (passno(i) .eq. pntall (ii, 1 ) } then 
npoints (i) -pntall (ii, 2 ) 
go to 35 
endif 

30 continue 

35 continue 

20 continue 

elseif (inf .eq. 21) then 
do 50 i-1, nlines 

passrec (i, 1 ) -passno (i ) 
do 40 ii-l # nlines 

if (passno(i) .eq. pntcnt (ii, 1 ) } then 
npoints (i) -pntcnt (ii, 2) 
go to 45 
endif 


40 continue 

45 continue 

50 continue 

endif 

c 

c npoints - number of records to allocate 

c for each pass number. nrecord - the output file 

c record positions for each pass 


nrecord (1 ) -1 
passrec (1, 2) -1 
do 60 i-2, nlines 
il-i-1 

nrecord (i ) -nrecord(il) + npoints < il > 
passrec (i, 2) -nrecord (i) 


60 continue 

c read each data point 

c 

c rewind (inf) 
inrec2-0 

70 inrec2-inrec2+l 

read (inf , rec-inrec2, err-90) (idata< j) , j-1,2), (data(k) ,k-l,27) 

c determine the matching pass number and its 

c output record numoer by searching all pass numbers 


do 80 i-1, nlines 

if (idata(l) .eq. passno (i) ) then 
write (onf , rec-nrecord (i) ) 

• (idata ( j) , >1,2), (data(k) , k-1, 27) 

c increment output record number for this pass number 

nrecord(i) -nrecora (i) +1 

c read next data point 

goto 70 



endif 


80 

continue 
go to 70 


90 

continue 



write (*,*) 

inrec2 - 1, ' TOTAL RECORDS READ FOR FILE*,! 


write (*,*) 

nrecord(nlines) -1 , * TOTAL RECORDS WRITTEN 1 , 


> 

• FOR FILE’, onf 


return 

end 

— weoe jammin 


c 

c 

c 

c 

SUBROUTINE SORT (N, choice ) 

double precision ra (4000) , aver (4000, 2 ), rra, cross 


integer passm)d(4000, 2) , n, choice 

common /orderl/ aver (4000, 2) , passm^d (4000, 2) , cross 
common /hsort/ ra(400Q) 

c this subroutine is written by the authors 

c of: Numerical Recipes (fortran); 

c The Art of Scientific Computing 

c Cambridge University Press 

c .989, p. 230 

c the routine is referred to as "heapsort** 

c Copyright (C) 1986, 1992 Numerical Recipes Software 
if (choice .le. 2) then 
do 10 i-1 , n 

ra (i ) -aver (i, choice) 
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10 continue 

elseif (choice .eq. 3) then 
do 30 1-1, n 

ra (i ) -dble (passm jd (i, 1 ) ) 

30 continue 

endif 
c 

L-N/2+1 

IR-N 

100 CONTINUE 

IF (L.GT.l )THEN 
L-L-l 
RRA-RA (L) 

ELSE 

RRA-RA (IR) 

RA(IR) -RA (1 ) 

IR-IR-1 

IF (IR. EQ. 1 ) THEN 
RA (1 ) -RBA 
RETURN 
ENDIF 
ENDIF 
I-L 
J-L+L 

200 IF ( J. LE . IR) THEN 

IF (J. LT. IR)THEN 

IF (RA (J) ,LT.RA(J+1) ) J-J+l 
ENDIF 

IF (RRA. LT. RA ( J) ) THEN 
RA (I)-RA(J) 

I-J 

J-J+J 

ELSE 

J-IR+1 
ENDIF 
GO TO 200 
ENDIF 
RA < I ) -RRA 
GO TO 100 
END 
C 

c 

c 

subroutine shorts (innum, hilat , lolat , dndk) 
integer innum, idata (400,2) ,dndk, shrtcnt, 

> shrtpas (3000, 2) , passrec (4000, 2) 

real data (400, 27) , hilat, lolat 
common data (400, 27} , idata (400, 2) 

common /shorty/ shrtpas (3000, 2) , shrtcnt, passrec (4000, 2) 


c 

c subroutine description 

c shorts determines if the pass is short, a short pass is 

c a pass which does not extend above the northern-most 

c (hilat) or below the southern-most (lolat). 

c 

if (dndk .eq. 0) then 

if (data (1,1) .gt. lolat .or. 

> data (innum, 1) .It. hilat) then 

shrtcnt-shrtcnt+l 
shrtpas (shrtcnt, 1) -idata (1, 1 ) 
shrtpas (shrtcnt, 2) -innum 


endif 

elseif (dndk .eq. 1} then 

if (data (innum, 1) .gt. lolat .or. 

> data (1,1) .It. hilat) then 
shrtcnt-shrtcnt+1 

shrtpas (shrtcnt, 1 ) -idata (1,1) 
shrtpas (shrtcnt, 2) -innum 
endif 
endif 
c 

return 

end 

c 

c 

c 

subroutine reorder3 (allcnt, dndk) 

Integer shrtpas (3000,2) , shrtcnt, passrec (4000, 2) , 

> allcnt, passnum, recnum, row, recnt, rrow, frow, 

> isdata (400, 2) , free, nrec, rrec, pass, if data (400,2) , 

> irdata (400, 2) , nument, min rrow, stocount,minfrow, 

> dndk, font, rent 

real sdata(400, 2) , fdata (400, 2) , rdata (400, 2) , sftdat (400, 2) , 

> ftdata (400, 2) , rtdata (400, 2) , totfdif f , totrdif f , 

> fdlf f, rdif f, totsft, totsrt , srtdat (400,2) 

double precision avgslon,avgrdif f , avgfdiff, savg Ion (4000,2) ,crosss 
common /shorty/ shrtpas (3000, 2) , shrtcnt, passrec (4000, 2) 
common /trunc/ sdata (400, 2) , fdata (400, 2) , rdata (400, 2) , 

> sftdat (400, 2) , ftdata (400, 2) , srtdat (400, 2) , 

> rtdata (400, 2) 
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common /order3/ savglon (4000, 2) , crosss 


c 

c- 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


50 


100 

c 

200 
c 


220 


c- 

c 

c 


235 


230 

238 

c 

c 

c 


240 


260 


c 


c 

270 


280 


s u br outine description 

this subroutine extends all short passes by adding or subtracting 
the average longitude difference from the closest full length 
pass, then calculates the true average longitude for the short 
pass, and stores that true average in an array, the short passes 
are found by subroutine shorts with a user defined percentage of total 
length to be considered as a long pass, as this percentage is 
increased the distance to the closest pass also increases such that 
there is more chance for error due to a poor fit of the average 
longitude, the closest full length pass is either west or east 
of the short pass, if west, then the average difference is added 
to the full length pass, however, if east then the average 
difference is subtracted, these values are then added to the 
longitudes of the short pass to create a set of full length 
longitudes which are averaged together to get the true average 
longitude, the fundamental principle involved here is that passes 
are always parallel and do not actually cross over each other, 
therfore, the difference between adjacent passes remains almost 
-or at least pretty dog-gone close to almost- constant. 


icnt-1 

continue 

do 100 i-1, allcnt 

if (shrtpas {lent, 1) .eq. passrec (i, 1 ) ) then 
recnum-passrec (i, 2) 
passnum-passrec (i, 1) 
row-shrtpas (icnt,2) 
reent-i 
go to 200 
endif 
continue 

continue 

read in the short pass 

do 220 i-1, row 

read (20, rec-recnum) (isdata (i, j) , j«l, 2) , (sdata (1, j) , j-1, 2) 
recnum-recnum+1 
continue 
recnum-recnum-1 

if (passnum ,ne. isdata (row, 1) ) then 

write (*,*) 'wrong pass number in reorder3' 
stop 
endif 

add 360.0 to longitudes that cross the 

-180.0 to 180.0 meridian so that averages 
are correct 

do 230 n-1, row-1 

if (sdata (n, 2) .It. sdata (n+1 , 2 } ) then 
do 235 i-1 , row 

if (sdata (i, 2 ) .It. 0.0) sdata (i, 2) -sdata (i , 2) *360.0 
continue 
go to 238 
endif 
continue 
continue 


find the starting record number for the 

nearest east pass 

frec-0 

numcnt-recnt+1 

if (nument .gt. allcnt) go to 270 

nrec-passrec (nument, 2) 

continue 

read (20, rec-nrec) pass 
do 260 i-l,shrtcnt 

if (pass .eq. shrtpas (i, 1 ) ) then 
nument -nument +1 

if (nument .gt. allcnt) go to 270 
nrec-passrec (nument , 2) 
go to 240 
endif 
continue 
frec-nrec 


find the starting record number for the 

nearest west pass 

continue 

rrec-0 

numcnt-recnt-1 

if (nument .It. 1) go to 300 
nrec-passrec (nument, 2) 
continue 

read (20, rec-nrec) pass 
do 290 i-l,shrtcnt 

if (pass .eq. shrtpas (i, 1 ) ) then 
numcnt-numcnt-1 
if (nument .It. 1) go to 300 
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nrec-passrec (numcnt,2) 
go to 280 
endif 
290 continue 
rrec-nrec 


— calculate the average longitude 


300 continue 

avgfdiff-1 0000.0 
if (free .gt. 0) then 
i-1 

read (20, rec-f rec,err-340) (ifdata (i, j) , j-1, 2) , 

> (fdata (i, j) , j-1, 2) 
i-i+1 

frec-frec+1 

320 read (20, rec-f rec, err-340) (ifdata (i, j) , j-1, 2) , 

> (fdata (i, j) , j-1, 2) 
if (ifdata (i-1, 1) .ne. ifdata (i,l)) go to 340 
frec-frec+1 

i-i+1 
go to 320 
340 continue 

f row -i-1 

do 344 n-1 , f row-1 

if (fdata (n, 2) .It. fdata (n+1, 2 ) ) then 
do 342 i-1, f row 

if (fdata (i, 2} .It. 0.0) fdata(i,2)-fdata(i,2)+360.0 


342 

continue 


go to 345 


endif 

344 

continue 

345 

continue 


c truncate the short and forward passes 

c to the same length 

c 

call truncate (row, f row, dndk, minfrow, stocount , passnum, 

> ifdata (frow, 1 ), 1 ) 


350 
c 


totfdif f-0. 0 

totsft-0.0 

do 350 i-1, minfrow 

fdiff-abs (sftdat (i, 2)-ftdata (i, 2) ) 
totfdif f-fdiff+totfdiff 
totsft-totsft+sftdat (i, 2) 
continue 

calculate the average longitude difference 

avgfdlf f-dble (tot fdiff /real (minfrow) ) 
endif 


c repeat the process for the closest west pass 

avgrdiff-1 0000.0 
if (rrec .gt. 0) then 
i-1 

read (20, rec-rrec) (irdata(i, j), j-1, 2), (rdata(i, j), j-1, 2) 
i-i+1 

rrec-rrec+1 

360 read (20, rec-rrec) (irdata (1, j) , j-1, 2> , (rdata (i, j ) , j-1, 2) 
if (irdata (i-1, 1) .ne. irdata (i,l)) go to 380 
rrec-rrec+1 
i-i+1 
go to 360 
380 continue 
rrow-i-1 

do 384 n-l,rrow-l 

if (rdata (n, 2) .It. rdata (n+1, 2 ) ) then 
do 382 i-1 , rrow 

if (rdata (i, 2) .It. 0.0) rdata (i, 2) -rdata (i, 2) +360. 0 
382 continue 

go to 385 
endif 

384 continue 

385 continue 

call truncate (row, rrow, dndk, minrrow, stocount, passnum, 

> irdata (rrow, 1) ,-l) 

totrdif f-0. 0 
totsrt-0. 0 
do 390 i-1, minrrow 

rdiff-abs (srtdat (i, 2) -rtdata (i, 2) ) 
totrdif f-rdif f+ totrdif f 
totsrt-totsrt+srtdat (i, 2) 

390 continue 

avgrdif f-dble (totrdif f /real (minrrow) ) 
endif 


c 

c if the east difference is the smallest 

c then use the east pass to calculate 

c average longitude of the extended short 

c pass 


if (avgfdiff .It. avgrdiff) then 
do 400 i-1 , frow 

if <ftdata(l,2) .eq. fdata(i,2}) then 
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400 

410 


420 

425 


430 

435 


440 

445 


450 

455 

c 

c 

c 


500 

510 


520 

525 


530 

535 


540 
54 5 


550 

555 


c 

c 


c 


c 

c 

c 


f cnt-i 
go to 410 
endif 
continue 
continue 

if (sftdat (1, 2 ) .It. ftdata(l,2)) then 
if (fcnt-1 .eq. 0) go to 425 
do 420 i-1, fcnt-1 

totsft-totsft+ (fdata (i, 2) -real (avgfdiff ) ) 
continue 
continue 

if (minf row+fcnt .eq. frow) go to 435 
do 430 i -mi nf row+fcnt, frow 

totsf t-totsft+ (fdata (i, 2) -real (avgfdiff) ) 
continue 
continue 

elseif (sftdat (1,2) .gt. ftdata (1,2)) then 
if (fcnt-1 .eq. 0) go to 445 
do 440 i-1, fcnt-1 

tot sft ™tots ft +■ (fdata (i, 2) +real (avgfdiff) ) 
continue 
continue 

if (minf row+fcnt .eq. frow) go to 455 
do 450 i -minf row+fcnt, frow 

totsft-totsft+ (fdata (i, 2) +real (avgfdiff) ) 
continue 
continue 
endif 

avgslon-dble (totsft ) /dble (frow) 

repeat the process if the west pass is 

the closest 

elseif (avgrdiff .It. avgfdiff) then 
do 500 i-1, rrow 

if (rtdata(l,2) .eq. rdata(i,2)) then 
rcnt-i 
go to 510 
endif 
continue 
continue 

if (srtdat (1,2) .It. rtdata (1, 2 ) ) then 
if (rcnt-1 .eq. 0) go to 525 
do 520 i-1, rcnt-1 

totsrt-totsrt+ (rdata (i, 2) -real (avgrdiff) ) 
continue 
continue 

if (minrrow+rcnt .eq. rrow) go to 535 
do 530 i-minrrow+rcnt, rrow 

totsrt»totsrt+ (rdata (i, 2) -real (avgrdiff) ) 
continue 
continue 

elseif (srtdat (1,2) .gt. rtdata (1,2)) then 
if (rcnt-1 .eq. 0) go to 545 
do 540 i-1, rcnt-1 

totsrt-totsrt+ (rdata (i, 2) +real (avgrdiff) ) 
continue 
continue 

if (minrrow+rcnt .eq. rrow) go to 555 
do 550 i -minrrow+rcnt, rrow 

totsrt-totsrt+ (rdata (l,2)+real (avgrdiff) ) 
continue 
continue 
endif 

avgslon-dble (totsrt ) /dble (rrow) 
endif 


store the average in array 

if (avgslon .gt. 180.0) avgslon - avgslon - 360.0 
savglon (lent, 1 ) -dble (passnum) 
savglon (lent , 2) -avgslon + crosss 

icnt-icnt+1 

if (lent .gt. shrtent) return 
go to 50 

end 


subroutine truncate (xrow, yrow, dndk,minrow, stocount, 

> xpassno,ypassno, fr ) 
integer xrow, yrow, stocount, rowii, rowinc, minrow, fr, 

> dndX, xpassno, ypassno 

real xdata (400, 2) , ydata (400, 2) , sftdat (400,2), ftdata (400, 2) , 

> adata, bdata, dif fab, abss, 

> rtdata (400, 2), srtdat (400, 2) 

common /trunc/ sdata (400, 2) , fdata (400, 2) , rdata (400, 2) , 

> sftdat (400,2) , ftdata (400, 2) , srtdat (400, 2) , 

> rtdata (400, 2) 
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c- 

c 

c 

c 


20 

50 

55 

60 

65 

80 


c- 

c 

c 


90 


c- 

c 

c 

c 

c 

c 

c 


c- 

c 

c 


110 


115 


c- 

c 

c 


c- 

c 


130 


150 


c- 

c 

c 


subroutine description 

truncate compares the input passes and truncates both 
passes to the same overlapping length. 

do 20 j-l,xrow 
do 20 jj-1,2 

xdata (j, j j) -sdata ( j, jj) 
continue 

if (fr) 50,50,60 
do 55 j-l,yrow 
do 55 jj-1,2 

ydata ( j, jj)-rdata< j, j j) 
continue 
go to 80 
do 65 j-l , yrow 
do 65 jj-1,2 

ydata (j, j j) -fdata( j, j j) 
continue 

continue 

stocount-0 

jj-1 

rowii-xrow 

rowinc-yrow 

loops from 90 to 200 increment through the 

two input passes and truncate the lengths 
to the same length 

continue 

adata-xdata ( j j, 1) 
bdata-ydata ( j j , 1 ) 
dif fab-adata-bdata 
abss-abs (dif fab) 

if (rowii .eq. 0 .or. rowinc .eq. 0) then 

if this happens, then the findgap subroutine from 

movetrunc will have to be implemented to remove 
the appropriate pass, so far, there hasn't been 
any problems, another alternative would be to 
use only the east or west pass instead of 
comparing both to the short pass. 

write (*,*) 'xrows (s) rowii,' yrows (',fr, ') rowinc 
write (*,*) 'big problem with pass number -• ,xpassno,ypassno 
write (*,*) 'xrow -',xrow, 1 yrow -*,yrow 
stop 
endif 

minrow-min (rowii, rowinc) 

if pass a (ii) matches pass b (inc) at 

beginning length then write to xdata and 
ydata and race to main program 
if (abss .It. 0.33) then 
if (fr .eq. -1) then 
do 110 ll-l,minrow 
do 110 kk-1,2 

srtdat (11, kk) -xdata (11, kk) 
rtdata (11, kk) -ydata (11, kk} 
continue 

elseif (fr ,eq. 1) then 
do 115 ll-l,minrow 
do 115 kk-1,2 

sftdat (11, kk) -xdata (11, kk) 
ftdata (11, kk) -ydata (11 , kk) 
continue 
endif 
return 
endif 

if pass a no mate ha the b data then find new 

a or b depending on whether or not ascending 
or descending order of independent variable 
if (abss .ge. 0.33) then 
stocount-stocount+1 

if this is a dusk pass then will count from 

-90.0 lat degrees toward the equator 
if (dndk .eq. 0) then 

if (xdata (jj,l) .gt. ydata (jj, 1)) then 
rowinc-rowlnc-1 
do 130 Rvn-1, rowinc 
do 130 kk-1,2 

ydata (mm, kk) -ydata (mm+1, kk) 
continue 

elseif (xdata ( j j, 1) .It. ydata (jj,l)} then 
rowii-rowii-1 
do 150 nn-1, rowii 
do 150 kk-1,2 

xdata (nn, kk) -xdata (nn+1, kk) 
continue 

endif 

if this is a dawn pass then will count from 
the equator toward the south pole 
that is decreasing independent variable 
elseif (dndk .eq. 1) then 
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if (xdata ( j j, 1 ) .It. ydata(jj,l)) then 
rowinc-rowinc-1 
do 160 rrm-1, rowinc 
do 160 XX-1,2 

ydata (mm, XX) -ydata {mm+1, XX) 

160 continue 

elseif (xdata(jj,l) .gt . ydata (jj,l)) then 
rowii-rowii-1 
do 170 nn-l,rowii 
do 170 XX-1,2 

xdata (nn, XX) -xdata (nn+1, XX) 

170 continue 

endif 
endif 
endif 
c 

go to 90 
c 

end 


c 

c 

c 

c 

subroutine interpl (dndX, num, ii) 
real data (400, 27) , xdata (27) , intpdata (400, 27) 
integer num,idata (400, 2) ,dndX 
common data (400, 27) , idata (400, 2) 
common /inta/ xdata (27) 
common /intb/ intpdata (400, 27) 
c 

c subroutine description 

c 

c the basic concept of this subroutine was provided by: 

c Dr. D.N. "TiXu" Ravat 

c Dept, of Geology 

c Purdue University 

c this subroutine linearly interpolates ALL 27-r variables by 

c basing the interpolation on the latitudes which are interpolated 

c at every 0.33 degrees of starting latitude, 

c 

ii-0 

xlat-real (int (data (1 , 1 ) *100 . 0) ) /100. 0 
if (dndX .eq. 0) then 

if (xlat .It. data (1,1)) xiat-xlat + 0.33 
i-1 

100 if (xlat. ge. data (1,1) .and. xlat . le. data U + l, 1 ) ) then 
call interp2 (i,xlat) 

xdata (2) -real (int (xdata (2 ) *100 . 0) ) /100. 0 

ii-ii+1 

do 150 j-1,27 

intpdata (ii, j) -xdata ( j) 

150 continue 

xiat-xlat + 0.33 

if (xlat ,gt. data(num,l)) return 
go to 100 

elseif (xlat .gt. data(i+l,l)) then 

i- i+1 

go to 100 
endif 
c 

elseif (dndX ,eq. 1) then 

if (xlat .gt. data(l,l)) xiat-xlat - 0.33 
i-1 

180 if (xlat . le.datad, 1) .and. xlat. ge. data (i+1, 1) ) then 
call interp2 (i,xlat) 

xdata (2) -real (int (xdata (2) *100.0) ) /100. 0 

ii- ii+1 

do 200 j-1,27 

intpdata (ii, j) -xdata ( j) 

200 continue 

xiat-xlat - 0.33 

if (xlat .It. data(num,l)) return 
go to 180 

elseif (xlat .It. data (1+1,1)} then 
i-i+1 
go to 180 
endif 
endif 
c 

end 

c 

c 

c 

subroutine interp2 (inum, xlat) 
real data (400, 27) ,diffdata (27) , xdata (27) 
integer inum, idata (400, 2) 
common data (400, 27) , idata (400, 2) 
common /inta/ xdata (27) 
c 

this subroutine is also from TiXu and is 
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c the interpolator {not to confused with the 

c terminator I) 

c 

do 100 i-1,27 

dif fdata (i) -data (inum, i)-data (inum+1, 1) 

100 continue 

do 120 i-1,27 

xdata (i) -data (inum, i)+ (xlat-data (inum, 1 ) }* 

> (dif fdata (i) /dif fdata (1 ) ) 

120 continue 

c 

return 

end 

c 

c 

c 

subroutine despike (npts,outnum) 
real data (400, 27) ,desdata (400, 27) , upper, lower 
integer ic (400) , outnum, var, idata (400, 2) 
common data (400, 27) , idata (400, 2) 
ccmmon /spike/ desdata (400, 27) , upper, lower, var 
c 

c this subroutine also provided by Tiku 

c 

c 

c PROGRAM DESPIKE 

C******************************************************************* 

PROGRAM DESPIKE REMOVES MOST SPIKES FROM THE INPUT DATA SET. 

HOWEVER, FOR BEST RESULTS, IT IS SUGGESTED TO RUN DESPIKE 
AT LEAST THREE TIMES FOR EXAMPLE: 


INPUT1 DESPIKE— > OUT PUT 1 

(OUTPUT1 - INPUT 2 ) — -DESPIKE— > OUTPUT 2 
(OUTPUT 2 - INPUT 3) —DESPIKE— > OUTPUT3. 


STILL, AFTER RUNNING DESPIKE THREE TIMES, IT FAILS TO ELIMINATE 
ORBITS WITH DISCONTINUOUS RESID VS LATITUDE PROFILES. 

PROGRAM DEGAP ATTEMPTS TO TAKE CARE OF SUCH PASSES. 


PARAMETERS TO CHECK: "UPPER" AND "LOWER" (IN NANOTESLAS): 

IF PROGRAM DESPIKE HAS DETERMINED OBSERVATION N TO BE 
A GOOD POINT, IT THEN SETS OUT TO DETERMINE IF POINT N+l 
IS A GOOD POINT. IT DOES THIS BY CHECKING THE POINTS 
N, N+l, AND N+2. OBSERVATION N+l WILL BE A GOOD POINT 
IF THE RESIDUAL DIFFERENCE BETWEEN POINT N+l AND THE 
POINT ABOVE IT (N OR N+2) IS LESS THAN "UPPER" AND 
IF THE RESIDUAL DIFFERENCE BETWEEN IT AND THE POINT 
BELOW IT (N+2 OR N) IS GREATER THAN "LOWER". 


DO 2 1-1,400 
IC (I) -1 
2 CONTINUE 


ARE THE FIRST NEW POINTS SPIKES? 
NOTE: DATA (U, 23) - RESID2 (U) 


1-1 

15 SL1- (DATA (1 + 1, var) -DATA (I, var) ) 

SL2 - (DATA ( I + 2 , var ) -DATA ( I , var ) ) 

SL3- (DATA ( I + 3 , var ) -DATA ( I , var ) ) 

SL4- (DATA (1+4, var) -DATA (I, var ) ) 

XSL-ABS (SL1+SL2+SL3+SL4 ) /4 . 0 

S2- (DATA (1+2, var) -DATA (1+1, var) ) 

I F (ABS (SLl ) .GT. (3.0*XSL) .OR.ABS(SLl) .GT. (ABS(3.0*S2) ) ) IC(I)-0 
IF(IC(I) .EQ.0) THEN 
I-I+l 
GO TO 15 
ENDIF 


ARE THE MID POINTS SPIKES? 


DO 20 J-I , NPTS-2 

SL2- (DATA ( J+l, var) -DATA ( J+2, var) ) 

IF (SLl. GT.UPPER.AND.SL2.LT. LOWER) IC(J+1)«0 
IF (SLl .LT. LOWER. AND. SL2 .GT. UPPER) IC (J+l ) -0 
SL1-SL2 
20 CONTINUE 


IS THE LAST POINT A SPIKE? 
K-NPTS-2 

25 IF (IC (K) . EQ . 0 ) THEN 
K-K-l 
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GO TO 25 
ENDIF 
C 

SL1-ABS (DATA (K, var) -DATA (NPTS-1 , var ) ) 
SL2-ABS (DATA (NPTS-1, var) -DATA (NPTS, var) ) 
SL3-ABS (DATA (K, var ) -DATA (NPTS, var) ) 

IF (IC (NPTS-1 J.EQ.O) THEN 

IF (SL1 .GT. (3.0*SL2) ) IC (NPTS) -0 
IF (SL3.GT. (3.0*UPPER) ) IC (NPTS) -0 
ENDIF 

IF (IC (NPTS-1 ).EQ.l) THEN 

IF (SL2.GT. (3.0*SL1)) IC(NPTS)-0 
ENDIF 
C 

C NOBS-0 

C DO 30 I-1,NPTS 

C IF (IC (I ) . EQ. 1 ) NOBS-NOBS+1 

C 30 CONTINUE 

C WRITE (6,*) IDATA(1, 1) , NOBS 

C 

outnum-0 
DO 35 1-1 , NPTS 

IF (IC (I) .EQ.l) THEN 
o u t n um-ou t num+ 1 
do 32 m-1,27 

desdata (outnum,m) -data (i,m) 

32 continue 

ENDIF 
35 CONTINUE 
C 

return 

END 
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C 

c 


program massage 
character*80 filename 
character*10 dndk 

real data (400, 27) , intpdata (400, 27) ,movdata (400, 27) , 
dstore (27) ,desdata (400, 27) , upper, lower, mean, 
varmax, mince, strintdat (400) 

integer idata (400, 2) , countall, innum,outnum, winlen2, incwen2, 

> istore (2) ,denum, enter, spknum, spkvar,mowar, choice, 

> vary, nowant (4000) , col, eight, zero, gf choice, 

> col3,mincheck,gftype,passrem, recnum,gfcnt,winlenl, 

> winlen2a,winlen2b 
common data (400, 27) 

common /intb/ intpdata (400, 27) 

common /move/ movdata (400, 27) , winlen2, incwen2,movvar,gftype, 

> varmax, mince, incwenl, winlenl, winlen2a, winlen2b 
common /spike/ desdata (400, 27) , upper, lower, spkvar 

common /trax/ x (400) , y (400) 


— program description 

c 

c ok, first the name of the program, to be frank, i just couldn't 

c think of shortened name for despike-moving-average-min-max- 

c cubic-spline-linear-interpolation... so i just called the 

c program "massage" because this program massages the data a bit!! 

c this program takes data in the 2-integers and 27-reals format 

c and after a bit of work writes the worked over data in either 

c 2i-27r or the more usual format of a file of latitudes, longitudes 

c and radii separated by headers and a file of residuals separated 

c by headers, the bit of work includes, 1) removing bad data points 

c characterized by a large change in magnitude from surrounding 

c data points, ie: removing "spikes". 2) fitting a moving average 

c to the despiked dataset. 3) interpolating every 0.33 degrees of 

c latitude on the moving average (guide function). 4) interpolating 

c the despiked dataset, interpolating schemes are linear for 

c the initial run through on a pass, then the gf is a spline, 

c 5) fit and remove a least squares core field from the data, 

c of course there are several variations on the above scheme which 

c can be figured out be reading the write {*,*) statements, 

c NOTE: if certain passes are NOT wanted, this program will 

c remove them from the processing. 

c NOTE: I've found that the bandpass filter works better than 

c removing a guide function or cubic spline, but u can 

c do as u like. 

c NOTE: for optimal results, make use of the least squares 

c core field removal as applied by massage, 

c NOTE: for ibm rs6000, recl-116. for dec3100, recl-29 

c 

c program date: 16 apr 91 

c 

write {*,*) 'INPUT 2I-27R FILE' 
read (*,9990) filename 
9990 format (a80) 

open (10, file-filename, status-'old' , form-' unformatted' , 

> access- ' direct ', recl-1 16) 


write (*,*) 'TYPE dawn OR dusk AS APPROPRIATE' 
read (*,9991) dndk 
9991 format (alO) 

write <*,*) '0 IF YOU WANT ALL PASSES' 

write (*,*) *1 IF CERTAIN PASSES NEED TO BE REMOVED* 

read (*,*) choice 

if (choice .eq. 1) then 

write (*,*) 'INPUT FILE OF PASSES YOU DO NOT WANT' 
read (*,9990) filename 

open (11, file-filename, status-'old' , form- ' formatted' ) 
endif 


write (*,*) '0 FOR CUBIC SPLINE AND DATA OUTPUT' 

write {*,*) *1 FOR ONLY CUBIC SPLINE OUTPUT' 
write (*,*) '2 FOR ONLY DATA OUTPUT (the usual choice)' 
read (*,*) gfchoice 

write (*,*) 'WHICH 27 R VARIABLE TO BE WRITTEN TO FILE(S) (12)' 
write (*,*) 'l-LAT, 2-LONG ,. ,12-bva, ... 23-tot avgmag' 
write (*,*) 'lat Ion rad mlt invlat diplat bs bv x y z' 

write (*,*) 'bva xa ya za totfld xfld yfld zfld inc dec' 

write {*,*) 'totmag totavgmag resid resavgmag ringcur sec ' 

write (*,*) '0 IF YOU WANT 2I-27R OUTPUT" 
read (*,*) vary 

write (*,*) *1 FIT LEAST SQUARES CORE FIELD TO THIS VARIABLE' 

write (*,*) '0 DO NOT FIT CORE FIELD' 

write (*,*) 'choose 1' 

read (*,*) ixfit 

if (ixfit .eq. 1) then 

write (*,*) 'OUTPUT FILE FOR PASS NUMBERS AND X VALUES' 

read (*, 9990} filename 

open (22, file-filename, form- ' formatted' ) 
endif 


c 

if (gfchoice .eq. 0 .or. gfchoice .eq. 2) then 
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if (vary .eq. 0) then 

write (*,*) 'OUTPUT 2I-27R DATA FILE' 
read (*,9990) filename 

open (20, file-filename, form-' unformatted* ) 
endif 

if (vary .gt. 0) then 

write (*,*) 'OUTPUT DATA FILE OF HEADERS AND VARIABLE' 
read (*,9990) filename 

open (20, file-filename, form-' unformatted' ) 
write (*,*) 'OUTPUT DATA FILE OF HEADERS’ 
write (*,*) 'AND INTERP-LATS, LONGS, RADII ' 
read (*,9990) filename 

open (21, file-filename, form-' unformatted* ) 
endif 
endif 

20 continue 

write (*,*) '0 FOR NO DESPIKING OF DATA SET' 

write (*,*) '1 FOR DESPIKING ONCE' 

write (*,*) '2 FOR DESPIKING TWICE (this is the usual choice)' 
write (*,*) *3 ... AND SO ON' 
read (*,*) spknum 
if (spknum .gt. 0) then 

write (*,*) 'WHAT IS THE MAXIMUM nT: (1.0)' 
write (*,*) 'WHAT IS THE MINIMUM nT: (-1.0)' 
read (*,*) upper, lower 

write (*,*) 'WHICH VARIABLE TO DESPIKE: (23)' 

write (*,*) '1-IAT, 2 -LONG, .. 12-bva, ... 23-totavgmag' 
write (*,*) 'lat 1cm rad mlt invlat diplat bs bv x y z' 

write (*,*) 'bva xa ya za totfld xfld yfld zfld inc dec' 

write (*,*) 'totmag totavgmag resid resavgmag ringcur sec ' 
read (*,*) spkvar 
endif 

if (gf choice .It. 2) then 

write (*,*) 'WHICH VARIABLE TO WORK WITH IN CUBIC SPLINE: (12) ' 
write (*,*) * 1-LAT, 2-LONG, .. 12-bva, ... 23-totavgmag' 
write (*,*) 'lat Ion rad mlt invlat diplat bs bv x y z’ 

write (*,*) 'bva xa ya za totfld xfld yfld zfld inc dec* 

write (*,*) 'totmag totavgmag resid resavgmag ringcur sec ' 
read (*,*) mowar 
if (vary .eq. 0) then 

write (*,*) 'OUTPUT 2I-27R CUBIC SPLINE FILE' 
read (*,9990) filename 

open (23, file-filename, form- ' unformatted' ) 
endif 

if (vary .gt. 0) then 

write (*,*) 'OUTPUT FILE OF CUBIC SPLINE VARIABLE* 
read (*,9990) filename 

open (23, file-filename, form-' unformatted' ) 
write {*,*) 'OUTPUT FILE OF CUBIC SPLINE HEADERS AND' 
write (*,*) 'AND I NTERP-LATS, LONGS, RADII ' 
read (*,9990) filename 

open (24, file-filename, form-' unformatted' ) 
write (*,*) 'OUTPUT FILE OF DATA - CUBIC SPLINE* 
read (*,9990) filename 

open (29, file-filename, form- ' unformatted' ) 
endif 

write (*,*) 'OUTPUT STATISTICS FILE* 
read (*,9990) filename 

open (25, file-filename, form-' formatted' ) 

write (25,*)’PASS VAR STDEV MIN MEAN MAX' 

write <*,*) 'OUTPUT FILE OF TRACKS FITTED WITH A CUBIC SPLINE* 
read (*,9990) filename 

open (26, file- filename, form- ' unformatted' ) 
write (*,*) 'OUTPUT FILE OF TRACKS NOT FITTED* 
read (*,9990) filename 

open (27, file-filename, form-' unformatted' ) 

write (*,*) 'TYPE OF CUBIC SPLINE TO APPLY TO DATA: (2)' 

write (*,*) '1 FOR A MOVING AVERAGE’ 

write (*,*) *2 FOR A MIN-MAX -AVERAGE FINDER' 

read (*,*) gftype 

if (gftype .eq. 1) then 

incwen2-0 

winlen2-0 

winlen2a-0 

winlen2b-0 

write (*,*) 'WHAT IS THE LENGTH OF THE WINDOW; 1 
read (*,*) winlenl 

write (*,*) 'HOW MANY POINTS TO INCREMENT WINDOW LOCATION:' 
write (*,*) 'should be equal to or greater than 1* 
read (*,*) lncwenl 
elseif (gftype .eq. 2) then 

write (*,*) 'LENGTH OF THE first AVERAGING WINDOW:' 
read (*,*) winlen2a 

write (*,*) 'LENGTH OF THE min-max AVERAGING WINDOW:' 
read (*,*) wlnlen2 

write {*,*) 'LENGTH OF THE last AVERAGING WINDOW:' 
read (*,*) winlen2b 

write (*,*) 'HOW MANY POINTS TO SEARCH FROM AN ENDPOINT TO FIND' 
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write (*,*) 'IF THE MIN OR MAX POINT SHOULD BE REMOVED* 
read (*,*) incwen2 

write (*,*) * IF MINCC CAN NOT BE MATCHED THEN* 

write (*,*) 'WHAT IS THE LENGTH OF THE AVERAGING WINDOW' 

read (*,*) winlenl 

write (*,*) 'IF MINCC CAN NOT BE MATCHED THEN' 

write (*,*) 'HOW MANY POINTS TO INCREMENT WINDOW LOCATION:' 

write {*,*) 'should be equal to or greater than 1' 

read (*,*) incwenl 

endif 

write (*,*) 'MAXIMUM VARIANCE WITHOUT FITTING A CUBIC SPLINE' 
read {*,*) varmax 

write (*,*) 'MINIMUM CORRELATION COEFFICIENT OF CUBIC SPLINE TO' 
write (*,*) 'ORIGINAL DATA* 
read (*,*) mince 
endif 

write (*,*) 'AND FINALLY - WHAT IS THE MINIMUM NUMBER OF' 
write (*,*) 'OBSERVATIONS ALLOWABLE FOR EACH PASS (50)' 


read (*,*) mincheck 
c 

if (choice .eq. 1) then 
do 50 kk-1,4000 

read (11, *, end-55) nowant (kk} 

50 continue 

55 continue 

choice -kk-1 
endif 
c 

c — read the data and find all lines 

c for each individual pass 


noc-0 

nocgf-0 

gfcnt-0 

itercnt-0 

passrem-0 

countall-0 

jstop-0 

ifirstcnt-0 

lseccnt-0 

iendcnt-0 

i3cnt-0 

i4cnt-0 

i5cnt-0 

16cnt«0 

i7cnt-0 

i8cnt-0 

ibigcnt-0 

iswitch-0 

ilowcnt-0 

recnum-1 

read (10, rec-recnum) (idata (1 , i ) , i-1, 2 ) , (data (1, j ) , j-1 , 27 ) 

100 n-2 

105 recnum-recnum+1 

read (10, rec-recnum, err-110) (idata (n, i) , i-1 , 2) , (data (n, j) , j-1, 27} 
if (idata (n, 1 ) .ne. idata (n-1, 1 ) ) go to 120 
n-n+1 
go to 105 
110 continue 
jstop-1 
120 continue 

do 130 1-1,2 

i store (i ) -idata (n, i) 

130 continue 

do 140 i-1, 27 

dstore (i) -data (n, i) 

140 continue 
c 

countall-countall+1 

c if passes are NOT wanted, remove them 

if (choice .eq. 0) go to 145 
do 63 ii-1, choice 

if (idata (1, 1 } , eq. nowant(ii)) then 
c write (*,*) 'PASS NUMBER REMOVED nowant (ii) , idata (1, 1 ) 

passrem-passrem+1 
go to 400 
endif 

63 continue 
145 continue 
c 

innum-n-1 

c 

if (innum .It. mincheck) then 

write (*,9900) idata (1, 1 ), innum 


9980 format (’PASS REMOVED AT READ -',i6,' OBSERV COUNT -’,i5) 
passrem-passrem+1 
go to 400 
endif 

c search for passes that cross the 

c -180.0 180.0 meridian 
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call meridian (innum) 

desplke the data if user chooses and 
despike the number of times chosen 

If (spknum .eq. 0) go to 190 
cnter-0 

150 call despike (innum, denum) 
cnter-cnter+1 
innum-denum 
do 180 k-1, innum 
do 180 kk-1,27 

data (k, kk) -desdata (k, kk) 

180 continue 

if (enter .It. spknum} go to 150 

190 continue 

if (innum .It. mincheck) then 

write (*,9981) idata (1 , 1 ), innum 
9981 format ('PASS REMOVED AFTER DESPIKING -',16, 

> ' OBSERV COUNT -\i5) 

pa ss r em-pa s s rem+ 1 
go to 400 
endif 


interpolate the dataset 

call interpl (dndk, innum, outnum} 
innum -outnum 

if (innum .It. mincheck) then 

write (*,9982) idata (1, 1 ), innum 
9982 format ('PASS REMOVED AFTER INTERPOLATING -*,i6, 

> ' OBSERV COUNT -*,i5) 

passrem-passrem+1 
go to 400 
endif 

do 205 i-1, innum 

x (1) -intpdata (i, 1} 
y(i) -intpdata (i, 2) 

205 continue 


c- 

c 


c 


“ ~ fit the core field (#16) profile to 

the chosen variable profile 

if (ixfit .eq. 1) then 

call sqr fit (innum, xxx, vary) 
write (22,*) idata (1, 1 ), xxx 
endif 


if (gfchoice .eq. 1) go to 300 

if (vary .eq. 0) go to 230 

col-1 

col 3-3 

zero-0 

mean-0.0 

eight-8888 

write (20) outnum, col, zero, mean, idata (1, 1) , eight 
write (21) outnum, col 3, zero, mean, idata (1, 1) , eight 


210 

230 

250 


do 210 m-1, outnum 

if (intpdata (m, 2) .gt. 100.0) intpdata (m, 2} -intpdata (m, 2} -360.0 
write (20) intpdata (m, vary) 

write (21) intpdata (m, 1), intpdata (m, 2), intpdata (m, 3) 
strintdat (m) -intpdata (m, vary) 
continue 


if (vary .gt. 0) go to 300 
do 250 i-1, outnum 

if (intpdata (1, 2) .grt. 180.0) intpdata(i,2)-intpdata(i, 21-360.0 
write (20) (idata (1, j) , j-1, 2) , (intpdata (i, j) , j-1, 27) 
continue 


c 

c 

c 

c 


300 


310 

c 


c 


this if statement if chosen, will fit 
the cubic spline, interpolate it and 
write it to file 

continue 

if (gfchoice .It. 2) then 
do 310 k-1, innum 
do 310 kk-1,27 

data (k, kk) -intpdata (k, kk) 
continue 

call moving (innum, num, idata (1, 1 ), eight, gfent, dndk, iterent, 
if irstent, iseccnt, iendent, i3cnt, i4cnt, i5cnt, 
ifient, 17cnt, i8cnt, ibigent, iswitch,ilowcnt) 

outnum-innum 


if (eight .eq. 7777) call track (27, innum, noc, noegf) 


if (vary .gt. 0) then 
col-1 
col 3- 3 
zero-0 
mean-0.0 
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if (eight .eq. 8888) then 

write (28) outnum, col, zero, mean, idata (1, 1) , eight 
write (23) outnum, col, zero, mean, idata (1, 1) , eight 
write (24) outnum, col3, zero, mean, idata (1,1) , eight 


c 

c 


350 


c 

c 


370 


c 

c 

c 

c 

400 

410 

420 


c 

999 


do m-1, outnum 

write (28) (strintdat (m) -intpdata (m, vary)) 
enddo 

elseif (eight .eq. 7777) then 
ieight-8888 

write (28) outnum, col, zero, mean, idata (1, 1) , ieight 
write (23) zero, col, zero, mean, idata (1,1) , eight 
write (24) zero, col3, zero, mean, idata (1, 1) , eight 
do m-l,outnum 

write (28) strintdat (m) 
enddo 
go to 400 
endif 

call track (26, outnum, noc, nocgf ) 

do 350 m-1, outnum 

if (intpdata (i, 2) .gt. 180. 0) 

> intpdata (i, 2) -Intpdata (i, 2) -360.0 
write (23) intpdata (m, vary) 

write (24) intpdata (m, 1 ), intpdata (m, 2) , intpdata (m, 3) 
continue 
endif 

if (vary .eq. 0) then 

if (eight .eq. 7777) then 
write (23) eight 
go to 400 
endif 

call track (26, outnum, noc, nocgf ) 

do 370 m-1, outnum 

if (intpdata (1,2) .gt. 180.0) 

> intpdata (i, 2} -intpdata (i, 2) -360.0 
write (23) (idata (l,mm) , mm-1 , 2 ) , 

> (intpdata (m, mm) , mm-1, 27) 
continue 

endif 

endif 

set idata (l,i) and data (1, i ) to the 

previously read values and go back and 
get the rest of the values for the pass 

continue 
do 410 i-1,2 

idata (1, i) -is tore (i) 
continue 
do 420 i-1,27 

data (1, i )-dstore (i) 
continue 

if ( J s top .eq. 1) go to 999 
go to 100 

continue 

write (*,*) 'records read -',recnum-l 

write (*,*) 'passes read -*,countall 

write (*,*) 'passes removed -',passrem 

write (*,*) 'passes fitted with a cubic spline -',gfcnt 

write (*,*) 'passes without a cubic spline 

> countall-gfcnt-passrem 
write (*,*) 'total extra iterations - ' , itercnt-gfcnt 
if (gftype .eq. 2) then 

write (*,*) ifirstcnt, ' first points were removed* 
write (*,*) iseccnt, ' second points were removed* 
write (*,*) iswitch, 1 orbits used a moving-average gf' 
endif 

write (*,*) iendcnt, * passes were 2nd order' 

write (*,*) i3cnt, ' passes were 3rd order* 

write (*,*) i4cnt, ' passes were 4th order’ 

write (*,*) iScnt, ' passes were 5th order* 

write (*,*) i6cnt, • passes were 6th order* 

write (*,*) i7cnt, ' passes were 7th order* 

write (*,*) i8cnt, ' passes were 8th order* 

write (*,*) ibigcnt, * passes were larger than 8th order* 

write (*,*) ilowcnt, * passes were below cc of', mince 

close (10) 

close (11) 

close (20) 

close (21) 

close (23) 

close (24) 

close (25) 

close (26) 

close (27) 

stop 
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end 


subroutine meridian (innuin) 
real data (400, 27) 
integer innum 
common data(400,27) 

c subroutine description 

c this subroutine determines if a pass crosses the -180.0 180.0 

c meridian, if a pass does cross, then 360.0 is added to the 

c negative values so that the interpolation scheme does not 

c try to interpolate from -180.0 to 180.0 every 0.33 degrees 

c 

do 100 i-l,innum-l 

if (data (i, 2) .It. data(i+l,2)) then 
do 150 ii-1, innum 

if (data (ii, 2) .It. 0.0) data (ii, 2) -data (ii, 2) +360.0 
150 continue 

go to 200 
endif 
100 continue 


200 


continue 

return 

end 


100 


150 


180 


200 


subroutine interpl (dndk, num, ii) 

real data (400, 27) ,xdata (27) , intpdata (400,27) 

integer man 

character*10 dndk 

common data (400, 27) 

common /inta/ xdata(27) 

common /intb/ intpdata (400, 27) 


subroutine description 

the basic concept of this subroutine was provided by: 

Dr. D.N. "Tiku" Ravat 
Dept, of Geology 
Purdue University 

this subroutine linearly interpolates ALL 27-r variables by 
basing the interpolation on the latitudes which are interpolated 
at every 0.33 degrees of starting latitude. 

ii-0 

xlat-real (int (data (1,1) *100.0) ) /100.0 
if (dndk .eq. 'dusk') then 

if (xlat .It. data (1,1) ) xlat-xlat + 0.33 
i-1 

if (xlat. ge. data (1,1) .and. xlat . le .data (1+1, 1 ) ) then 
call interp2 (i,xlat) 

xdata (2) -real (int (xdata (2 ) *100. 0) )/100.0 

ii-ii+1 

do 150 3-1,27 

intpdata (ii, j) -xdata (j) 
continue 

xlat-xlat + 0.33 

if (xlat ,gt. data(num,l)) return 
go to 100 

elseif (xlat .grt. data(i + l,l)) then 

i- i+1 

go to 100 
endif 

elseif (dndk .eq. ‘dawn*) then 

if (xlat .gt. data (1,1)) xlat-xlat - 0.33 
i-1 

if (xlat. le. data (i,l) .and. xlat. ge. data <i+l, 1) ) then 
call interp2 (i,xlat) 

xdata (2) -real (int (xdata (2) *100.0) ) /100.0 

ii- ii+1 

do 200 j-1,27 

intpdata (ii, 3)-xdata(3) 
continue 

xlat-xlat - 0.33 

if (xlat .It. data (num, 1 ) ) return 
go to 180 

elseif (xlat .It. data (i+1, 1)) then 
i-i+1 
go to 100 
endif 
endif 


end 


B-38 



subroutine interp2 (inura, xlat) 

real data (400, 27) ,diffdata (27) ,xdata (27) 

integer inum 

cannon data (400,27) 

common /inta/ xdata(27) 


c 

c — • this subroutine is also from Tiku and is 

c the interpolator (not to confused with the 

c terminator!) 

c 

do 100 i-1 , 27 

dif fdata (i) -data (inum, 1) -data (inum+1 , i) 

100 continue 

do 120 1-1,27 

xdata ( i ) -data (inum, i) ♦ (xlat-data (inum, 1 ) ) * 

> (dif fdata (i) /dif fdata (1 ) ) 

120 continue 

c 


return 

end 


SUBROUTINE SPLINE (X, Y, N, YPl , YPN, Y2 ) 

PARAMETER (M4AX-100) 

DIMENSION X (N) ,Y (N),Y2 (N) ,U (M4AX) 
c 

c suDroutine description 

c this subroutine provided by the autnors of Numerical Recipes 

c Numerical Recipes (fortran) 

c The Art of Scientific Computing 

c Cambridge University Press, 1989 

c Copyright (C) 1906, 1992 Numerical Recipes Software 
IF (YPl .CT. . 99E30) THEN 
Y2 (1 ) -0. 

U(l)-0. 


ELSE 

Y2(l)— 0.5 

U(l)-(3,/(X(2)-X(l)) ) * ( (Y (2 ) -Y (1) ) / (X (2) -X (1 ) ) -YPl ) 
ENDIF 

DO 11 1-2, N-l 

SIC- (X(I)-X(M))/(X(I + U-X(I-1) ) 

P-SIG*Y2 (I-l)*2. 

Y2 (I) - (SIC-1 . ) /P 

U(I}-(6.*( (Y (1*1 )-Y (I } ) / (X <1 + 1 ) -X (I ) ) - (Y (I) -Y (1-1 ) ) 

* /(X(I)-X(I-l) ) )/ (X(I+1)-X(I-1) >-SIG*U(I-l> )/P 

11 CONTINUE 

IF (YPN.GT. . 99E30) THEN 
QN-0. 

UN-0. 

ELSE 
QN -0.5 

UN- <3. / (X (N) -X (N-l ) ) ) * (YPN- ( Y (N) - Y (N-l > ) / (X (N) -X (N-l ) ) ) 
ENDIF 

Y2 (N) - (UN-QN*U (N-l ) ) / (QN* Y2 (N-l ) + 1 . ) 

DO 12 K-N-l, 1,-1 

Y2 (K) -Y2 (K) *Y2 <K+1)+U(K) 

12 CONTINUE 
RETURN 
END 


SUBROUTINE SPLINT (XA, YA, Y2A, N, X,Y) 
DIMENSION XA (N) , YA (N) , Y2A (N) 


c— — subroutine description 

c Copyright (C) 1986, 1992 Numerical Recipes Software 
KLO-1 
KHI-N 

1 IF (KHI-KLO.CT. 1) THEN 


K- (KHI+KLO) /2 
IF (XA (K) . GT.X) THEN 
KHI-K 
ELSE 
KLO-K 
ENDIF 
GOTO 1 
ENDIF 

H-XA (KHI ) -XA (KLO) 

IF (H.EQ.0.) PAUSE 'Bad XA input.* 

A- (XA (KHI > -X) /H 
B- (X-XA (KLO) ) /H 
Y-A*YA (KLO) +B*YA (KHI) + 

* ( (A** 3-A) *Y2A(KLO) + (B**3-B) *Y2A(KHI) ) *(H**2)/6. 

RETURN 
END 


suoroutine moving (nobs, inum, passnum, eight , gfent, dndk. 
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> ltercnt, ifirstcnt, iseccnt, iendcnt, 

> 13cnt, i4cnt, 15cnt, i6cnt, i7cnt, i8cnt, 

> ibigcnt,iswitch,ilowcnt) 
integer winlen, incwen, nobs, minm, 

> wwinlen2, iincwen2, iincwenl, var,maxm, 

> gftype, passnum, eight, gf cnt, subwinlen, strnobs, 

> TOf type , wwinlenl, wwinlen2a, wwinlen2b 
real data (400, 27) ,movdata (400,27) ,minval,maxval, 

> varmax, strdata (400, 27) , intpdata (400, 27) , mince, 

> x (100) ,y (100) , y2 (100) , 

> sdata (400, 27) 
character*10 dndk 
common data (400, 27) 

common /move/ movdata (400, 27) ,wwinlen2, iincwen2, var, ggftype, 

> varmax, mince, iincwenl , wwinlenl , wwinlen2a, 

> wwinlen2b 
common /intb/ intpdata (400, 27) 


subroutine description 


subroutine moving creates the cubic spline fit of each pass with 
a variance above the user defined limit, this cubic spline will 
match the original pass to within the user defined correlation 
coefficient, the cubic spline is the time domain representation 
of the non-lithospheric components in the pass, the following 
source was used as a reference for the statistical calculations: 


Davis, Statistics and Data Analysis in 
Geology, 2nd ed., 1986 pp. 41 


-loops that sum x, x**2 


st mobs -nobs 

xsum-0.0 

xsumsar-0.0 

xmin-data ( 1 , var ) 

xmax-xmin 

do 10 j-l,nobs 

xsum-xsum+data ( j, var) 
xsumsqr-xsumsqr+ (data ( j, var) ) **2 
xmin-min (xmin, data ( j, var) ) 
xmax-max (xmax, data ( j, var) ) 

10 continue 

nobss-float (nobs) 

c find corrected sum of squares and mean 

c 

xcsumsqr-xsumsqr- { (xsum**2) /nobss) 
xmea n -xs um/n obs s 

c find variance, standard deviation 

c 

xvar-xcsumsqr/ (nobss-1 .0) 
xstdev-sqrt (xvar) 

c write out this mess for individual pass 

c 

write (25,9992) passnum,xvar,xstdev,xmin,xmean,xmax 
9992 format (16,5fl4.5) 
c 

c if the variance of the pass is below the user 

c defined limit then race on back to main program 

If (xvar ,le. varmax) then 
eight-7777 
return 
endlf 

gftype-ggftype 
gfcnt-gfcnt+1 
do 15 i-1 , nobs 
do 15 j-1 , 27 

strdata (i, j)-data (I, J) 
continue 


15 


subwinlen-0 


use a moving average fit 


17 if (gftype .eq. 1) then 
itercnt-itercnt+1 
wlnlen-wwinlenl 
incwen-iincwenl 
inum-1 

if (subwinlen .gt. 0) then 
if (incwen .gt. 1) then 
lncwen-incwen-subwinlen 
go to 25 

elseif (incwen .It. winlen) then 
wi nl e n— winlen-s ubwi nlen 
if (winlen .It. 2) stop 1110 
endif 

25 continue 

endif 

xdivide-real (nobs) /real (incwen+winlen-1) 
xp5- (real (int (xdivide) ) )+0.5 
if (xdivide .It. xp5) idivide-int (xdivide) 
if (xdivide .ge. xp5) idivide-lnt (xdivide) +1 
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xwinlen-real (nobs) /real (idivide) 

iwinadd-int ( (xwinlen- (real (int (xwinlen) ) ) ) *real (idivide) ) 
winlen-int (xwinlen) -incwen 
istrwinlen-winlen 
i add-0 

if (iwinadd ,gt. 0 .and. iadd .It. iwinadd) then 

i add-1 add+1 

winlen-winlen+1 

endif 

11- (winlen-1) /2 
i3-il 

17-0 

if (il .grt. nobs) then 
il-nobs/2 
i7-l 
endif 

avgdat-0.0 
do j-l,il 

avgdat-data ( j, var) +avgdat 
enddo 

do 20 j-1,27 

mo v data (inum, j) -data (1, j) 

20 continue 

movdata (inum, var ) -avgdat/ (real (11 ) ) 
if (i 7 ,eq. 1) go to 100 
30 continue 

winlen-istrwinlen 

if (iwinadd .gt. 0 .and. iadd .It. iwinadd) then 

iadd-iadd+1 

winlen-winlen+1 

endif 

12- i3+incwen 

13- i2+winlen-l 

14- i2+((i3-i2)/2) 

if (13 .gt. nobs-il+1) go to 100 

avgdat-0.0 

inum-inum+1 

do 50 j-12,13 

avgdat-avgdat+data ( j, var ) 

50 continue 

do 70 j-1,27 

movdata (inum, j) -data (14, j) 

70 continue 

movdata (inum, var) -avgdat/ (13-12+1 ) 


go to 30 

100 continue 
inum-inum+1 


avgdat-0.0 

do j- (nobs-il+1 ), nobs 

avgdat-avgdat+data ( j, var) 
enddo 

150 do 170 j-1,27 

movdata (inum, j ) -data (nobs, j ) 

170 continue 

movdata (inum, var ) -avgdat/ (real (il ) ) 

c or use the minimum and maximum values 

c within the window length 

c 


elseif (gftype .eq. 2) then 
itercnt-itercnt+1 
winlen-wwinlen2 
incwen-iincwen2 
winlena-wwinlen2a 
winlenb-wwinlen2b 

if (winlena.gt.nobs .or. winlenb. gt . nobs .or. 

> incwen. gt . nobs .or. (wlnlena+1 ) .ge . (nobs-winlenb) ) then 

do 1-1,27 

movdata (1, i) -data (1 , i ) 
movdata (2, i) -data (nobs,i) 
enddo 

avgdat-0.0 
do i-1, nobs/2 

avgdat-data (i, var) +avgdat 
enddo 

avgdat-avgdat/real (nobs/2) 
movdata (1, var ) -avgdat 
avgdat-0. 0 
do i- (nobs/2 ) +1, nobs 

avgdat-data (i, var) +avgdat 
enddo 

avgdat-avgdat/real (nobs- (nobs/2 ) ) 
movdata (2, var) -avgdat 
iendcnt-iendcnt+1 
inum- 2 
go to 700 
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endif 

avgdat-0.0 

do 500 1-1 , winlena 

500 

avgdat-data (i, var) +avgdat 

avgdat-avgdat/real {winlena) 
do 510 i-1,27 

510 movdata (1, i) -data (1, i) 

movdata (1, var } -avgdat 

11- winlena+1 

12- nobs-wlnlenb 

13- 0 

14- noba-wlnlanb+l 

15- nobs 

16- nobs 

maxval— 1 .OelO 
minval-l.OelO 
do 520 m-il, 12 

minval-min (minval, data (m, var) ) 
if (minval .eq. data (m, var) ) minm-m 
maxval-max (maxval , data (m, var ) ) 
if (maxval .eq. data (m, var)) maxm-m 
520 continue 

ilow-minm- ( (wlnlen-1) /2) 
ihi-minm+{ (winlen-l)/2) 
if (ilow .It. 1) ilow-1 
if {ihi .gt. nobs) ihi-nobs 
avgdatmin-0. 0 
do 530 i-ilow, ihi 

530 avgdatmin-avgdatmin+data (i, var) 

avgdatmin-avgdatmin/real (ihi-ilow+1 ) 

ilow-maxm- ( (winlen-1 ) /2 ) 

ihi-maxm+ ( (winlen-1 )/ 2 ) 

if (ilow .It. 1) ilow-1 

if (ihi .gt. nobs) ihi-nobs 

avgdatmax-0. 0 

do 540 i-ilow, ihi 

540 avgdatmax-avgdatmax+data (i, var) 

avgdatmax-avgdatmax/real (ihi-ilow+1) 
if (minm .It. maxm) then 
do 570 j-1,27 

movdata (2-fi3, j ) -data (minm, j) 
movdata (3+i3, j) -data (maxm, j) 
movdata ( 2+ i 3, var ) -a vgdatmin 
movdata (3+13, var ) -avgdatmax 
570 continue 

elseif (minm .grt. maxm) then 

do 590 j-1,27 

movdata (2+13, j ) -data (maxm, j) 
movdata (3+i3, j ) -data (minm, j ) 
movdata (2+i3, var ) -avgdatmax 
movdata (3+i3, var ) -avgdatmin 
590 continue 

endif 

avgdat-0.0 
do 594 i-i4, 15 

594 avgdat-data <i, var) +avgdat 

avgdat-avgdat/real (i5-i4 + l) 
do 596 i-1,27 

596 movdata (4+13, i) -data (i6, i) 

movdata (4+i3, var ) -avgdat 
inum-4+i3 

if (dndk .eq. 'dusk') then 
if (movdata (2+13, 1) .le. 

> (movdata (1+13, 1)+ (real (incwen) *0.33) ) ) then 
if ir s ten t-if ir stent +1 

do 600 j-2,3 

do 600 i-1,27 

600 movdata ( j+i3, i ) -movdata ( j+1+13, i) 

inum-inum-1 
endif 

if (movdata (inum-1+13, 1 ) .ge. 

> (movdata (inum+i3, 1)- (real (incwen) *0.33) } ) then 
iseccnt-iseccnt+1 

do 610 i-1,27 

610 movdata (inum-*l+i3, i ) -movdata (inum+i3, 1) 

inum-inum-1 
endif 

elseif (dndk .eq. •dawn') then 
if (movdata (2+13,1) .ge. 

> (movdata (1+13,1)- (real (incwen) *0.33) ) ) then 
ifirstcnt-ifirstcnt+1 

do 620 j-2,3 
do 620 i-1,27 

620 movdata ( j+i 3, i ) -movdata ( j+1 + 13, i) 

inum-inum-1 
endif 

if (movdata (lnum-1+13, 1) .le. 

> (movdata (inum+i 3, 1)+ (real (incwen) *0.33) ) ) then 
iseccnt-lseccnt+1 
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630 


do 630 i-1,27 

mo v data (inum-1+13, i ) -movdata (inum+i3, i) 
inum-inum-1 
endif 
endif 
endif 

700 continue 

if (dndlc .eq. 'dusk') then 
do 401 i-1, inum 

x (i) -movdata (i, 1) 
y (i) -movdata (i, var) 

401 continue 

elseif (dndk .eq. 'dawn') then 
do 404 i-l,inum 
ii-inum-i+1 
x (i) -movdata (ii, 1) 
y (i) -movdata (ii, var) 

404 continue 

endif 

oneslope- <y (2)-y (1) ) / (x <2}-x (1 ) ) 
twoslope- (y (inum) -y (inum-1 ) ) / (x (inum) -x (inum-1) ) 
call spline (x,y, inum, oneslope, twoslope, y2) 
do 402 i-1, nobs 
ii-nobs-i+1 
xint-data (i r 1) 

if (dndk .eq. 'dawn') xint-data {ii, 1 ) 
call splint (x,y,y2,inum,xint,yint) 
do 403 j-1, 27 

intpdata (i, j) -data (1, j) 

if (dndk .eq. 'dawn') intpdata (i, j) -data (ii, j) 

403 continue 

intpdata <i, var} -yint 

402 continue 

if (dndk .eq. 'dawn') then 


do 405 i-1, nobs 
ii-nobs-i+1 
do 405 j-1,27 

sdata (i, j) -intpdata {ii, 3) 

405 continue 

do 406 i-1, nobs 
do 406 j-1, 27 

intpdata (i, j) -sdata (i, j) 

406 continue 
endif 

c 

c calculate the correlation coefficient between 

c the original data and the cubic spline 

c 

c loops that sum x, x**2, y, y**2 and xy 


if {nobs .ne. strnobs) stop 0002 

nobss-real (nobs) 

xsum-0.0 

xsumsqr-0. 0 

y sum-0 . 0 

ysumsqr-0 . 0 

sumxy-0. 0 

do 440 j-1, nobs 

xsum-xsum+strdata ( j, var) 
xsumsqr-xsumsqr+ (strdata ( j, var ) } **2 
ysum-ysum+intpdata ( j, var) 
ysumsqr-ysumsqr+ (Intpdata ( j, var ) ) **2 
sumxy-sumxy+ (strdata (j, var) ‘intpdata ( j, var) ) 
440 continue 


c find corrected sum of products, covariance 

c and corrected sum of squares (x) (y) 

c 


sumprod-sumxy- ( (xsum‘ysum) /nobss) 
covarxy-sumprod/ (nobss-1 . 0) 
xcsumsqr-xsumsqr- ( (xsum* *2) /nobss } 
yc sums qr-ys urns qr- { (ysum**2) /nobss) 
c 

c find variance, standard deviation for x and y 

c 

xvar-xcsumsqr/ (nobss-1. 0) 
yvar-ycsumsqr/ (nobss-1 .0) 
xstdev-sqrt (xvar) 
ystdev-sqrt (yvar) 


c find correlation coefficient by Davis method 

corrDxy-covarxy/ (xstdev*ystdev) 
c 

c if the fit between cubic spline and original data 

c is below the minimum acceptable user defined 

c correlation coefficient limit, then shorten the 

c windows by a length equivalent to subwinlen. then 

c rerun the entire subroutine from statement 17 

c 

if (corrDxy .It. mince .and. gftype ,eq. 2) then 

write (*,*) passnum, ' pass below cc limit ', corrDxy 
gftype-1 
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uuuuu 


iswitch-iawitch+l 
do 450 i-l,nobs 
do 450 j-1,27 

data (i, j)-strdata (1, j) 

450 continue 
go to 17 
endif 

if (corrDxy .It. mince .and. gftype .eq. 1} then 
if (i7 .eq. 1) then 

write (*,*) passnum, ' pass below cc limit corrDxy 
ilowcnt-ilowcnt+1 
go to 999 
endif 

subwinlen-aubwinlen+1 
do 460 i-l f nobs 
do 460 j-1,27 

data (i, j)-strdata (i, j) 

460 continue 
go to 17 
endif 
c 

999 eight-8888 

write (60,*) passnum, corrDxy 
if (inum .eq. 2) iendcnt-iendcnt+1 

if (inum .eq. 3) i3cnt-i3cnt+l 

if (inum .eq. 4) i4cnt-14cnt+l 

if (inum .eq. 5) 15cnt-i5cnt+l 

if (inum .eq. 6) i6cnt-i6cnt+l 

if (inum .eq. 7) i7cnt-i7cnt+l 

if (inum .eq. 8) i8cnt-i8cnt+l 

if (inum .gt. 8) ibigcnt-ibigcnt+1 

return 
end 
c 
c 
c 
c 

subroutine despike (npts,outnum) 

real data (400, 27) , desdata (400, 27) , upper, lower 

integer ic (400) , outnum, var 

common data (400, 27) 

cawnon /spike/ desdata (400, 27 ), upper, lower, var 
c 


c this subroutine also provided by Tiku 

c 

c 

C PROGRAM DESPIKE 

£******************************+************+***#********★********** 
C PROGRAM DESPIKE REMOVES MOST SPIKES FROM THE INPUT DATA SET. 

C HOWEVER, FOR BEST RESULTS, IT IS SUGGESTED TO RUN DESPIKE 

C AT LEAST THREE TIMES FOR EXAMPLE: 

C 

c INPUT1 — -DESPIKE— > OUTPUT 1 

C (0UTPUT1 - INPUT2) — -DESPIKE™ > OUTPUT 2 

C (0UTPUT2 - INPUT3) — -DESPIKE— -> OUTPUT 3. 

C 

C STILL, AFTER RUNNING DESPIKE THREE TIMES, IT FAILS TO ELIMINATE 
C ORBITS WITH DISCONTINUOUS RESID VS LATITUDE PROFILES. 

C PROGRAM DEGAP ATTEMPTS TO TAKE CARE OF SUCH PASSES. 


C 

C 

C PARAMETERS TO CHECK: “UPPER" AND “LOWER'* (IN NANOTESLAS) : 

C 

C IF PROGRAM DESPIKE HAS DETERMINED OBSERVATION N TO BE 
C A GOOD POINT, IT THEN SETS OUT TO DETERMINE IF POINT N+l 

C IS A GOOD POINT. IT DOES THIS BY CHECKING THE POINTS 

C N, N+l, AND N+2 . OBSERVATION N+l WILL BE A GOOD POINT 

C IF THE RESIDUAL DIFFERENCE BETWEEN POINT N+l AND THE 

C POINT ABOVE IT (N OR N+2) IS LESS THAN "UPPER" AND 
C IF THE RESIDUAL DIFFERENCE BETWEEN IT AND THE POINT 
C BE LCW IT (N+2 OR N) IS GREATER THAN “LOWER**. 

C********* ********************************************* ******** A 4 AA 

C 

DO 2 1-1,400 
IC(I)-1 
2 CONTINUE 

****************************************************************** 
ARE THE FIRST NEW POINTS SPIKES? 

NOTE: DATA (U, 23) - RESID2 (U) 

1-1 

15 SL1- (DATA (1+1, var) -DATA (I, var) ) 

SL2- (DATA (1+2, var) -DATA (I, var) ) 

SL3- (DATA (I +3, var) -DATA (I, var)) 

SL4- (DATA (I +4, var) -DATA (I, var)) 

XSL-ABS (SL1+SL2+SL3+SL4 ) /4 . 0 
C 

S2- (DATA (1 + 2, var) -DATA (1+1, var) ) 
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IF (ABS (SL1) .GT. (3.0*XSL) .OR. ABS (SLl) .GT. (ABS (3. 0*S2) ) ) IC(I)-0 
IF (IC (I) .EQ. 0) THEN 
I-I + l 
GO TO 15 
ENDIF 


**************************************************************** 

ARE THE MID POINTS SPIKES? 

DO 20 J-I,NPTS-2 

SL2- (DATA (J+l, var ) -DATA ( J+2, var) ) 

IF (SL1 . GT. UPPER. AND. SL2 .LT. LOWER) IC (J+l ) -0 
IF (SL1 .LT. LOWER. AND. SL2 .GT. UPPER) IC (J+l ) -0 
SL1-SL2 
20 CONTINUE 

********************** ************************* ****************** 

IS THE LAST POINT A SPIKE? 

K-NPTS-2 

25 IF (IC (K) . EQ. 0) THEN 
K-K-l 
GO TO 25 
ENDIF 

SL1-ABS (DATA (K, var ) -DATA (NPTS-1 , var) ) 

SL2 -ABS (DATA (NPTS-1 , var ) -DATA (NPTS, var) ) 

SL3-ABS (DATA (K, var) -DATA (NPTS, var ) ) 

IF(IC (NPTS-1) .EQ.O) THEN 

IF (SL1 .GT. (3 ,0*SL2 ) ) IC(NPTS)-0 
IF (SL3.GT. (3.0*UPPER) ) IC (NPTS) -0 
ENDIF 

IF (IC (NPTS-1 ) .EQ.l) THEN 

IF (SL2.GT. (3.0*SLl)) IC(NPTS)-0 
ENDIF 

NOBS-0 

DO 30 I-1,NPTS 

IF (IC (I) .EQ.l) NOBS-NOBS+1 
30 CONTINUE 

WRITE (6,*) I DATA (1 , 1 ) , NOBS 

outnum-0 
DO 35 1-1 , NPTS 

IF (IC (I } .EQ.l) THEN 
outnum-outnum+1 
do 32 m-1,27 

desdata (outnum,m) -data (i , m) 

32 continue 

ENDIF 
35 CONTINUE 
C 

return 

END 

c 

c 

c 

subroutine track, (nf , innum, noc, nocgf) 
common /trax/ x (400) ,y (400) 

c subroutine description 

c this subroutine calculates the lat Ion coordinates of each point 

c to be plotted in tplot for a map view of the footprint of the pass 

c 

RADFAC-0. 017453293 
nop-innum 

if (nf .eq. 26) nocgf-nocgf +1 

if (nf .eq. 27) noc-noc+1 

DO 200 J-l , NOP 

x ( j)-90.0-x< j) 

if (y(j).it.o.) y ( j)-y ( J) +360. 

X(J) -X(J) * RAD FAC 
Y (J) -Y ( J) *RADFAC 
200 CONTINUE 

if (nf .eq. 26) WRITE (26) NOCgf , NOP, (X (J) , Y (J) , J-l, NOP) 

if (nf .eq. 27) WRITE (27) NOC, NOP, (X (J) , Y (J) , J-l, NOP) 

c 

return 

end 

c 

c 

c 

c 

c 

subroutine sqrfit (innum, x, ifitvar) 
real core (400) ,xmag (400) , intpdata (400, 27 ) 
common /intb/ intpdata (400, 27) 

c subroutine description 

c sqrfit fits the core field values to the observed data 

c in a least squares manner. that is, the subroutine finds 

c a value of x that is multiplied by all core field values 
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c in a pass so that the core field model matches the 

c observed values closer, 

c 

*• 0.0 
cmean-0.0 
fmean-0.0 
do i-1, lnnum 

core (i) -intpdata (i, 16) 
anean-cmean+core (i) 
xmag (i) -intpdata (i, ifitvar) 
fmean-fmean+xmag (i) 
enddo 
c 

anean-cmean/real (innum) 
fmean-fmean/real (innum) 
c 

do i-l # innum 

xmag (i) -xmag (i) -fmean 
core (i ) -core (i ) -cmean 
enddo 
c 

ctc-0. 0 

do 600 i-1, innum 

600 etc- (core (i) *core (i) ) +ctc 
c 

ctcinv-l.O/ctc 

c 

ctf-0.0 

do 700 i-1, innum 

700 ctf- (core (i ) *xmag(i) ) +ctf 
c 

x-ctcinv*ctf 

c 

do 800 i-1, innum 

800 intpdata (i, ifitvar) -xmag (i) - (core (i) *x) 
c 
c 

999 continue 
return 
end 
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program move t rune 

integer xrow,xcol, zero, eight, xpassno,vpassno,ycol, 

> x3row, x3col, x3pass,y3row,y3col,y3pass, yrow, 

> etrent, nobs, dndfc, t count, pairent, nowant (4000) , noent, 

> paircntl, j stop, mi nobs, pass rem, totpass, global , 

> out to, nopass, type, noc 

real xmean,ymean,x3data (400, 3) ,y3data (400, 3) ,y3mean, 

> xldata (400) ,yldata (400) ,xadata (400, 4) ,ybdata (400, 4) , 

> x3mean, xamean, ybroean, x(400) ,y (400) 
character* 80 filename 

common /tplot/ x (400) ,y (400) 

common /nope/ nowant (4000) , noent 

common /trunatat/ x a data (400, 4) , ybdata (400, 4) 

cccranon /rowcol/ x3row,y3row,xrow,yrow, x3col, y3col,xcol, ycol, 

> x3mean, y3mean, xmean, ymean, x3pass, y3pass , 

> xpassno, ypassno 

common x3data (400, 3) , xldata (400) ,y3data (400, 3) ,yldata (400) 
c 

c program description 

c 

c this program truncates, in the time domain, two adjacent passes 

c to the same length, this program should be used only after the 

c passes have been reordered by program reorder, truncation is 

c accurate in the time domain rather than in the frequency domain, 

c this program is used before program fourier which is used to 

c extract the similar wavelengths of adjacent passes, 

c 

c program date: 16 apr 91 

c 

write (*,*) ‘INPUT FILE X OF LAT-LONG -RAD DATA* 
read (*,9990) filename 
9990 format (a80) 

open (10, file-filename, status-'old* , form-' unformatted' ) 
write (*,*) 'INPUT FILE X OF MAGNETIC VARIABLES' 
read (*,9990) filename 

open (11, f ile-filename, status- 'old', form-' unformatted' ) 
c 

write (*,*) '0 IF THE DATA IS GLOBAL OR POLAR' 

write (*,*) '1 IF THE DATA DOES NOT INCLUDE ALL LONGITUDES' 

read (*,*) global 

if (global .eq. 0) then 

write (*,*) 'NOTE: FILE Y WILL HAVE THE FIRST PASS MOVED' 
write (*,*) 'TO THE BOTTOM OF THE FILE' 
write (*,*) ' ' 
elself (global .eq. 1) then 

write <*,*) 'NOTE: OUTPUT FILE X WILL NOT INCLUDE THE LAST PASS' 
write (*,*) ' FILE Y WILL NOT INCLUDE THE FIRST PASS' 

write (*,*) ' ‘ 
endif 
c 

write (*,*) 'OUTPUT FILE X OF TRUNCATED LAT-LONG-RAD DATA* 
read (*,9990) filename 

open (20, file-filename, form- ' unformatted' ) 

write (*,*) 'OUTPUT FILE X OF TRUNCATED MAGNETIC VARIABLES' 

read (*,9990) filename 

open (21, file-filename, form-' unformatted' ) 

write (*,*) 'OUTPUT FILE Y OF TRUNCATED LAT-LONG-RAD DATA* 

read (*,9990) filename 

open (22, file-filename, form- ' unformatted' ) 

write (*,*) 'OUTPUT FILE Y OF TRUNCATED MAGNETIC VARIABLES' 

read (*,9990) filename 

open (23, f ile-filename, form- 'unformatted' ) 

write (*,*) 'OUTPUT FILE OF TRACK PROFILES TO BE RUN IN TPLOT' 
read (*,9990) filename 

open (24, f ile-filename, form- ' unformatted' } 
write (*,*) 'OUTPUT FILE OF STATISTICS' 
read (*,9990) filename 

open (25, file-filename, form-' formatted' } 
c 

write (*,*) '0 IF THESE ARE DUSK DATA SETS* 
write (*,*) '1 IF THESE ARE DAWN DATA SETS' 
read (*,*) dndk 

write (*,*) '0 IF ALL PASSES ARE WANTED* 
write (*,*) *1 IF SOME PASSES SHOULD BE REMOVED' 

read (*,*) noent 
if (noent .eq. 1) then 

write (*,*) 'INPUT FILE OF PASS NUMBERS NOT WANTED' 
read (*,9990) filename 

open (26, file- filename, status-' old' , form-' formatted' ) 
do 10 1-1,4000 

read (26, *, end-15) nowant (1) 

10 continue 

15 continue 

nocnt-i-1 
endif 

write (*,*) 'MINIMUM NUMBER OF OBSERVATIONS FOR EACH PASS' 
read (*,*) mi nobs 

write (*,*) 'TYPE OF GAP FINDER (2)' 

write (*,*} '1 FOR ONLY FINDING GAPS' 

write (*,*) *2 FOR USING THE MINIMUM OBSERVATIONS' 
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read (*,*) type 


write (*,*) 1 

write {*,*) 'running through dataset to find passes'. 


> ' that do not overlap' 

c 

c subroutine findgap locates passes that do not 

c have overlapping segments and removes the 

c shorter of the two passes, the subroutine 

c continues reading and rereading the dataset 

c until all non-overlapping segments are removed 

c 


call findgap {global, dndk, minobs, type) 
write (*,*) 'done with run through' 

write (*,*> ' ' 

c 

write (25,*) 'XPASS YPASS CCD CCY XVAR YVAR 

> ' COVARXY XSTDEV YSTDEV ' 

write {25, * ) ' XMEAN YMEAN XSLOPE YSLOPE', 

> ' XINTCPT YINTCPT' 
paircnt-0 

paircnt 1-0 
tcount-0 
strcnt-0 
jstop-0 
passrem-0 
totpass-0 
c 

30 continue 

read (10, end-90) y3row, y3col, zero, y3mean, y3pass, eight 
do 35 i-l,y3row 

read (10) {y3data U, ii) , ii-l,y3col) 

35 continue 

read (11) yrow, ycol, zero, ymean, ypassno, eight 
do 45 i-i,yrow 

read (11) yldata(i) 

45 continue 

totpass-totpass+1 

if (yrow .It. minobs .or. y3row .It. minobs) then 

write (*, *)y3pass, ypassno, ' PASS REMOVED: ROWS-' , y3row, yrow 
pas s r em- pa s s r em+ 1 
go to 30 
endif 

if (nocnt .eq. 0) go to 55 
do 50 i«l, nocnt 

if (ypassno .eq. nowant (i)) then 

write (*,*) ypassno, y3pass, ' PASS REMOVED* 
passrem-passrem+1 
go to 30 
endif 
50 continue 
55 continue 
go to 95 

c this little jump around is used 

c to get the last and first passes 

c 


of global datasets truncatted 


90 jstop-1 

if (global .eq. 1) go to 999 
c 

95 continue 

strcnt-strcnt+1 

c offset the data file in subroutine 

c movtrun 

if (strcnt .eq. 1) call movtrun (-1, outto, jstop) 
if (strcnt .gt. 1) call movtrun (0, outto, jstop) 
if (outto) 30,100,100 

c truncate the passes to the same length 

100 continue 
nopass-0 

call truncate (xrow, yrow, dndk, nobs, paircnt 1 , nopass, 

> xpassno, ypassno) 

if (nopass .gt. 0) then 

c if this happens, then subroutine 

c 


findgap didn't work just right 

write (*,*) 'OH MAN HAVE YOU GOT TROUBLE NOW' 

stop 

endif 

c do a little statistical nonsense 

c 

call statistics (nobs, xpassno, ypassno, xamean, ybmean) 
c 
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write out the truncated lengths of passes 

c 

write {20) nebs, x2col, zero, xarrvean, xpassno, eight 
write (21) nobs, xcol, zero, xamean, xpassno, eight 
write (22) nobs, y3col, zero, ybraean, ypassno, eight 
write (23) nobs, ycol, zero, ybmean, ypassno, eight 
do 200 j-l,nobs 

write (20) xadata (j, 1) , (xadata (j, i) ,i-3, 4) 
write (21) xadata (j, 2) 

write (22) ybdata ( j, 1) , (ybdata ( j, i) , i-3, 4) 
write (23) ybdata(j,2) 

200 continue 
c 

call track (nobs,noc) 

WRITE (24) NOC,NObs, (X(J),Y(J) , J-l,NObs) 
c 

if (paircntl .gt. 0) tcount-tcount+1 
paircnt-paircnt+paircntl 
if (jstop .eq. 1) go to 999 
c 

call movtrun (1, outto, jstop) 
if (outto) 30,999,999 
c 
c 

999 continue 

if (global .eq. 1) strcnt-strcnt-1 

write (*,*) 'corrected' ,paircnt, * pairs of latitudes in' 
write (*,*) tcount, ' passes to beginning lengths' 
write (*,*) 'total passes read - ',totpass 
write (*,*) 'removed' , pass rem, ' passes from processing' 
write (*,*) 'total passes written - ',strcnt 
close (10) 
close (11) 
close (20) 
close (21) 
close (22) 
close (23) 
close (25) 
stop 
end 
c 
c 
c 

subroutine truncate (xrow,yrow,dndk,minrow, stocount, nopass, 

> xpassno, ypassno) 

integer xrow,yrow, stocount, rowii,rowinc,minrow,nocnt, 

> dndk, nopass, minxyrow, nowant (4000) , xpassno, ypassno 
real xdata (400,4 ) ,ydata(400, 4) , 

> x3data (400, 3) , xldata (400) , y3data (400, 3) ,yldata (400) , 

> adata, bdata, dif fab, abss, xadata (400, 4) , ybdata (400, 4) 
ccmmon /trunstat/ xadata (400, 4 ) , ybdata (400, 4 ) 

common /nope/ nowant (4000) , noent 

common x3data (400, 3) , xldata (400) ,y3data (400, 3) ,yldata (400) 


c 

c subroutine description 

c 

c this subroutine truncates two sets of values to the same length, 

c truncation is based on the independent variable which is the 

c latitude of each point along a pass, these values must be 

c interpolated to every 0.33 degrees, 

c 


do 70 j-1 , xrow 

xdata ( j, l)-x3data( j,l) 
xdata ( j, 2) -xldata ( j) 
xdata ( j, 3) -x3data ( j, 2) 
xdata ( j , 4 ) -x3data < j , 3 ) 

70 continue 

do 75 j-l,yrow 

ydata ( j, 1) -y3data ( j, 1 ) 
ydata (j, 2) -yldata ( j) 
ydata ( j, 3) -y3data ( j, 2 ) 
ydata ( j, 4}-y3data( j, 3) 

75 continue 
c 

00 continue 

stocount-0 

j j-1 

rowii-xrow 

rowinc-yrow 

c loops from 90 to 200 increment through the 

c two input passes and truncate the lengths 

c to the same length 

90 continue 

adata-xdata { j j, 1 ) 
bdata-ydata ( j j, 1) 
dl f fab- adata -bdata 
abss-abs (dif fab) 

if (rowii .eq. 0 .or. rowinc .eq, 0) then 
minxyrow-min (xrow, y row) 
if (minxyrow .eq. xrow) then 
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nopass -xpassno 
nowant (nocnt+1 ) -xpassno 

write (*,*) ’xrows (ii) -^rowii,' yrows (inc) rowinc 

write (*,*) ’rerunning to remove x pass number xpassno 

write (*,*) *xrow -*,xrow, * yrow -',yrow 
return 

elseif (minxyrow ,eq. yrow) then 
rvopass-ypassno 
nowant (nocnt+1) -ypassno 

write (*,*) ’xrows (ii) rowii, • yrows (inc) rowinc 

write (*,*) ‘rerunning to remove y pass number ypassno 

write (*,*) ‘xrow -',xrow, ' yrow -',yrow 
return 
endif 
endif 

minrow^nin (rowii, rowinc) 
c write (*,*) rowii, rowinc, minrow 

c write (*,*) adata, bdata, abss 

c if pass a (ii) matches pass b (inc) at 

c beginning length then write to xdata and 

c ydata and race to main program 

if (abss .It. 0.33) then 
do 110 11-1, minrow 
do 110 kk-1,4 

xadata (11, kk) -xdata (11, kk) 
ybdata (11, kk) -ydata (11, kk) 
c write (*,*) xdata (11) , ydata (11) 

110 continue 

return 
endif 

c if pass a no mat cha the b data then find new 

c a or b depending on whether or not ascending 

c or descending order of independent variable 

if (abss .ge. 0.33) then 
stocount-stocount+1 

c if this is a dusk pass then will count from 

c -90.0 lat degrees toward the equator 

if (dndk .eq. 0) then 

if (xdata (jj, 1) .gt. ydata(jj,l)) then 
rowlnc-rowinc-1 
do 130 rnn-1 , rowinc 
do 130 kk-1,4 

ydata (mm, kk) -ydata (imi+1 , kk) 
c write (*,*) ydata (mm, kk) 

130 continue 

elseif (xdata ( j j, 1 ) .It. ydata (jj,l)) then 


rowii-rowii-1 
do 150 nn-1, rowii 
do 150 kk-1,4 

xdata (nn, kk) -xdata (nn+1, kk) 

150 continue 

endif 

c if this is a dawn pass then will count from 

c the equator toward the south pole 

c that is decreasing independent variable 


elseif (dndk .eq. 1) then 

if (xdata (jj,l) .It. ydata(jj,l)> then 
rowinc-rowinc-1 
do 160 rrm-1, rowinc 
do 160 kk-1,4 

ydata (mm, kk) -ydata (mm+1, kk) 
c write (*,*} ydata (mm, kk) 

160 continue 

elseif (xdata(jj,l) .gt. ydata()j,l)) then 
rowii-rowii-1 
do 170 nn-1, rowii 
do 170 kk-1,4 

xdata (nn, kk) -xdata (nn+1, kk) 

170 continue 

endif 
•ndif 
endif 
c 

go to 90 
c 

end 


c 

c 

c 


c 

c 

c 

c 

c 

c 


subroutine statistics (minrow, xpassno, ypassno, xamean,ybmean) 
integer minrow, nobs, xpassno, ypassno 
real xadata (400,4), ybdata (400, 4) , nobss 
common /trunstat/ xadata (400, 4 ) , ybdata (400, 4 ) 

the statistical calculations using two 
references : 

1) Davis, Statistics and Data Analysis in 
Geology, 2nd ed. , 1986 pp. 41 

2 ) Young, Statistical Treatment of Experi- 
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c 

c 

c- 

c 


240 

c 

c 

c 

c 


mental Data, 1962, McCraw Hill, 115-132 

loops that sum x, x**2, y, y**2 and xy 

and calculate new truncate means 

nobs^ninrow 
nobss-float (nobs) 
xsum-0.0 
xsumsqr -0.0 
ysum-0.0 
ysumsqr-0.0 
sumxy-0. 0 
do 240 j-l,nobs 

xsum-xsum+ xadata ( j, 2) 
xsumaqr-xsumsqr+ (xadata ( j , 2 ) ) * * 2 
ysum-ysum+ybdata ( j , 2 ) 
ysurasqr-ysumsqr+ (ybdata ( j, 2) )**2 
sumxy-sumxy+ (xadata ( j, 2) *ybdata ( j, 2) ) 
continue 

write (*,*) xsum,yaum, xsumsqr, ysumsqr, sumxy 

find corrected sum of products, covariance 

and corrected sum of squares (x) (y) 


xamea n-x sum/ nobs s 
ybcnea n-y sum/ nobs s 
sumprod- sumxy- ( (xsum*ysum) /nobss) 
covarxy- sumprod/ (nobss-1 .0) 
xcsumsqr-xsumsqr- ( <xsum**2) /nobss) 
ycsumsqr-ysumsqr- ( <ysum**2) /nobss) 
c 

c find variance, standard deviation for x and y 

c 

xvar-xcsumsqr / (nobss-1 . 0 ) 
yvar-ycsumsqr/ (nobss-1 .0) 
xstdev-sqrt (xvar) 
ystdev-sqrt (yvar) 

c find correlation coefficient by Davis method 

corrDxy-covarxy/ (xstdev*vstdev) 

c find slopes, intercepts and correlation 

c coefficient by Young method 

xslope- ( (nobss * sumxy ) - <xsum*ysum) ) / ( (nobss* xsumsqr) -xsum**2) 
yslope- ( (nobss * sumxy ) - (xsum*ysum) ) / ( (nobss* ysumsqr) -ysum**2) 
xintcpt- ( (ysum*xsumsqr) - (sumxy *xsum) ) / ( (nobss*xsumsqr) -xsum**2) 
yintcpt- ( (xsum*ysumsqr) - (sumxy*ysum) ) / ( (nobss*ysumsqr) -ysum**2) 


corrYxy-sqrt (xslqpe*y slope) 
c 

c write out this mess for individual pass and 

c overlapping lengths of passes 

c 

c write (25, 9992 )xpassno,ypassno, xvar, yvar, xstdev, ystdev, 

c > xamean, ybmean 

9992 format (' FOR OVERLAPPING LENGTHS X«\i5,* Y-',i5,/, 

> ’X VARIANCE- \f 9.3, ' Y VARIANCE- f 9 . 3, * XSTDEV-', 

> f 9. 3, ’ Y STDEV- ' , f 9. 3, ' XMEAN- ' , f 9. 3, * YMEAN-* , f9. 3) 

c write (25,9993) covarxy, corrDxy 

9993 format ('COVARIANCE XY-',f9.3,' Davis CORRELATION COEF-',f9.3) 

c write (25,9994) xslope, xintcpt , yslope, yintcpt, corrYxy 

9994 format ('X SLOPE- • , f 9 . 3, ' X INTERCEPT- f 9. 3, * Y SLOPE-', 

> f9.3, * Y INTERCEPT-' , f 9.3, * Young CORRELATION C0EF-* 

> f 9. 3, /) 
c 


write (25,9995) xpassno, ypassno, corrDxy, corrYxy, xvar, yvar, 

> covarxy, xstdev, ystdev 

9995 format (215, 7 (f 10. 4) ) 

write (25,9996) xamean, yfcmean, xslope, yslope, xintcpt , yintcot 

9996 format (lOx, 6 (f 10. 4) ) 
return 

end 


c 

c 

c 


c 


subroutine movtrun (into, outto, jstop) 
integer into, outto, sy3row, syrow, sy3col, sycol, 

> sy3pass, sypassno, jstop, 

> y3row, yrow, y3col, ycol,y3pass, ypassno, 

> x3row, xrow, x3col, xcol , x3pass, xpassno, 

> sx3row, sxrow, sx3col, sxcol, sx3pass, sxpassno 

real x3data (400, 3) ,xldata (400) , y3data (400, 3} ,yldata (400) , 

> sy3mean, symean, savey3 (400, 3), saveyl (400) , y3mean, 

> ymean, x3mean, xmean, storex3 (400, 3) , storexl (400) , 

> sx3mean, sxmean 

ccmmon x3data (400, 3) , xldata (400) ,y3data (400, 3) ,yldata(400) 
common /rowcol/ x3row,y3row, xrow, yrow, x3col,y3col, xcol, ycol, 

> x3mean, y3mean, xmean, ymean, x3pass, y3pass, 

> xpassno, ypassno 


subroutine description 

c this subroutine stores one pass so that the offset 

c will occur. 

if (jstop) 10,10,350 
10 if (into) 40,85,290 
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40 continue 

do 50 i-l,y3row 
do 55 ii-l,y3col 

aavey 3 (i , ii > -y 3data (i , ii ) 

55 continue 

savey 1 (i ) -yldata (i ) 

50 continue 

•y3row-y3row 
ayrow-yrow 
sy3col-y3col 
sycol-ycol 
ay3mean-y3mean 
ayraean-ymean 
ay3pass-y3pass 
sypas sno-ypas sno 
c 

do 70 i-l,y3row 
do 75 ii-l,y3col 

x3data ( i , ii ) -y3data (i , ii ) 

75 continue 

xldata <i) -yldata (i) 

70 continue 

x3row-y3row 
xrow-yrow 
x3col-y3col 
x col -y col 
x3mean-y3mean 
xmean-ymean 
x3pass-y3pass 
xpas sno-ypas sno 
c 

outto - -1 
return 
c 
c 

85 continue 

do 90 i-l,y3row 

do 95 il-l,y3col 

storex3 (i, ii) -y3data (i,ii) 

95 continue 

storexl (i) -yldata (i) 

90 continue 

sx3row-y3row 
s xrow-yrow 
sx3col-y3col 
sxcol-ycol 
sx3mean-y3mean 
sxmean-ymean 
sx3pass-y3pass 
sxpassno-ypassno 
c 

if (xrow . ne . x3row .or. xpassno. ne . x3pass .or. 

> yrow.ne.y3row .or. ypassno. ne.y3pass ) then 

write <*,*) ‘WACKO, TRA-LA-LA, JOLLY-GOOD, NO MATCH BETWEEN* 
write (*,*) ’ROWS OR PASSNOS X- 1 , xrow, x3row, xpassno, x3pass 
write (*,*)' Y- yrow, y3row, ypassno, y3pass 

stop 
endif 
c 

outto - 0 
return 
c 
c 

290 continue 

x3row-sx3row 

xrow-sxrow 

x3col-sx3col 

xcol-sxcol 

x3mean-sx3mean 

xmean-sxinean 

x3pass-sx3pass 

xpassno-sxpassno 

do 300 i-l,x3row 

do 305 ii-1, x3col 

x3data(i,ii)-storex3 (i,ii) 

305 continue 

xldata (i) -storexl (i) 

300 continue 
c 

outto - -1 
return 
c 
c 

350 continue 

do 360 i-l,sy3row 

do 365 ii-1, sy3col 

y 3data (1 , ii ) -savey 3 {i , 11 ) 

365 continue 

yldata (i) -savey 1 (i ) 
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360 continue 

y3row-sy3row 
yrow-syrow 
y3col-sy3col 
ycol-aycol 
y3mean-sy3mean 
ymean-symean 
y3pass-sy3pass 
ypa ss no- sypas sno 
c 

outto - 0 
return 
c 

end 


c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 


subroutine findgap (global, dndk, mi nobs, type) 
integer zero, eight, minxyrow, xrow, yrow, type, 

> y3row, y3col, y3pass,xcnt, ycnt, strmincnt, 

> dndk, nowant (40u0) , nocnt, xpas sno, ypassno, 

> minobs, to tpass, global, both, nocnt 2, 

> nopass, st moon t,allcnt 

real y3data (400, 3) ,y 3mean, abss, alldata (4000,4 > 
common /nope/ nowant (4000) , nocnt 

~ subroutine description 

findgap locates two adjacent passes that do not have 
any coranon overlapping segment, if it finds two such 
passes, then it removes the shorter of the two, continues 
running through the remainder of the data while searching 
for non-overlapping passes, and finally reruns through 
the data set to assure that all non-overlapping passes 
have been located. 


totpass-0 
allcnt -0 
strnocnt-nocnt 

— read through the data only once and 

store the pass number, first lat and 
last lat in array alldata 

30 continue 

read (10, end-60) y3row, y3col, zero, y3mean, y3pass, eight 
do 35 i-l,y3row 

read (10) (y3data (i, il) , ii-l,y3col) 

35 continue 

totpass-totpass+1 
if (y3row .It. minobs) go to 30 
if (nocnt .eq. 0) go to 55 
do 50 i-1, nocnt 

if (y 3pass .eq. nowant (i) ) go to 30 
50 continue 
55 continue 

allcnt-allcnt+ 1 

alldata (allcnt, 1 ) -real (y3pass) 
alldata (allcnt, 2 ) -real (y3row) 
alldata (allcnt, 3) -y3data (1,1) 
alldata (allcnt , 4 ) -y3data (y3row, 1) 
go to 30 
60 continue 

• depending on the type of gap 


finder chosen, the program 
c 

if (type .eq. 2) go to 400 
c 


will proceed as appropriate 


70 


C' 

c 


c- 

c 

c 


90 


80 


continue 
j stop-0 

xcnt and ycnt represent the two 
adjacent passes 

xcnt-1 

ycnt-2 

the next two if statements check 
if one of the two adjacent passes 
is not wanted 

if (nocnt .eq. 0) go to 100 
do 80 i-1, nocnt 

if (int (alldata (xcnt, 1 ) } .eq. nowant (i) ) then 
do 90 j j-xcnt,allcnt-l 
do 90 j-1,4 

alldata (jj, j) -alldata ( jj+1, j) 
continue 
alien t-allcnt-1 
go to 70 
endif 
continue 


100 continue 

if (nocnt .eq. 0) go to 140 
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do 110 i-1, nocnt 

if (lnt (alldata (ycnt, 1) ) .eq. nowant (i) ) then 
if (ycnt+1 .gt. allcnt) then 
ycnt-ycnt+1 
go to 195 

elseif (jstop .eq. 1) then 
ycnt-ycnt+1 
go to 100 
•ndlf 

do 105 ji-ycnt,allcnt-l 
do 105 j-1,4 

alldata ( j j, j) -alldata (jj+1, j) 

105 continue 

allcnt-allcnt-1 
go to 100 
endif 
110 continue 
140 continue 
both-0 

abss-abs {alldata (xcnt, 3) “alldata (ycnt, 3) ) 
if (abss .It. 0.33) go to 190 
if (abss .ge. 0.33) then 

c truncation time! 

xrow-int (alldata (xcnt, 2) ) 
yrow-int (alldata (ycnt, 2) ) 
xpassno-int (alldata (xcnt, 1) ) 
ypassno-int (alldata (ycnt, 1) ) 
minxyrow-min (xrow, yrow) 
nopass-xpassno 

if (minxyrow .eq. yrow) nopass -ypass no 
if (xrow .eq. yrow) both-1 
nocnt2-nocnt 


c if this is a dusk pass then will count from 

c -90.0 lat degrees toward the equator 


if (dndk .eq. 0) then 

if (alldata (xcnt, 3) .gt. alldata (ycnt , 3) ) then 
if (alldata (xcnt, 3} .gt. alldata (ycnt, 4) ) then 
nocnt-nocnt+1 
nowant (nocnt ) -nopass 
endif 

elseif (alldata (xcnt, 3) .It. alldata (ycnt, 3) ) then 
if (alldata (xcnt, 4) .It. alldata (ycnt, 3) ) then 
nocnt-nocnt+1 
nowant (nocnt ) -nopass 
endif 
endif 


c if this is a dawn pass then will count from 

c the equator toward the south pole 

c that is decreasing independent variable 


elseif (dndk ,eq. 1} then 

if (alldata (xcnt, 3) .It. alldata (ycnt, 3) ) then 
if (alldata (xcnt , 3) .It. alldata (ycnt , 4 ) ) then 
nocnt-nocnt+1 
nowant (nocnt ) -nopass 
endif 

elseif (alldata (xcnt, 3) .gt. alldata (ycnt, 3) ) then 
if (alldata (xcnt, 4) .gt. alldata (ycnt, 3) ) then 
nocnt-nocnt+1 
nowant (nocnt) -nopass 
endif 
endif 
endif 

if (nocnt .gt. nocnt2 .and. both .eq. 1) then 
nocnt-nocnt+1 
nowant (nocnt) -xpassno 
endif 
endif 
c 

190 continue 
xcnt-ycnt 
ycnt-ycnt+1 

If (}stop .eq. 1) go to 200 
195 if (ycnt .gt. allcnt) then 

if (global .eq. 1) go to 200 
ycnt-1 
jstop-1 
endif 
go to 100 
c 

200 continue 

if (nocnt .eq. strnocnt) go to 999 
if (strnocnt .It. nocnt) then 
strnocnt-nocnt 
go to 70 
endif 
c 
c 

400 continue 
mincnt-0 
strmincnt-mincnt 
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c 

470 continue 
jstop-0 

c xcnt and ycnt, see notes above 

xcnt-1 
ycnt -2 

if (int (alldata (xcnt, 2) ) .It. minobs) then 
do 490 jj-xcnt, allcnt-1 
do 490 j-1,4 

alldata ( j j, j) -alldata (jj+1, j) 

490 continue 

allcnt-allcnt-1 
go to 470 
endif 
c 

500 continue 

if (int (alldata (ycnt, 2) ) .It. minobs) then 
if (ycnt+1 .gt. allcnt) then 
ycnt-ycnt+1 
go to 595 

elseif (jstop ,eq. 1) then 
ycnt -ycnt+1 
go to 500 
endif 

do 505 jj-ycnt, allcnt-1 
do 505 j-1,4 

alldata ( j j, j) -alldata (jj+1, j) 

505 continue 

allcnt-allcnt-1 
go to 500 
endif 

510 continue 
540 continue 

abss-abs (alldata (xcnt, 3) -alldata (ycnt , 3) ) 
if (abss .It. 0.33} go to 590 
If (abss . ge. 0.33) then 
xrow-int (alldata (xcnt, 2) ) 
yrow-int (alldata (ycnt, 2) ) 
minxyrow-min (xrow, yrow) 
mi nc n 1 2 -*ni nc nt 


c ? if this is a dusk pass then will count from 

c -90.0 lat degrees toward the equator 


if (dndk .eq. 0) then 

if (alldata (xcnt, 3) .gt. alldata (ycnt, 3} } then 

if (alldata (xcnt, 3) .gt. alldata (ycnt, 4) } mincnt-mincnt+1 
elseif (alldata (xcnt, 3) .It. alldata (ycnt, 3) } then 

if (alldata (xcnt, 4} .It. alldata (ycnt, 3) } mincnt-mincnt+1 
endif 


c if this is a dawn pass then will count from 

c the equator toward the south pole 

c that is decreasing independent variable 


elseif (dndk .eq. 1) then 

if {alldata (xcnt, 3) .It. alldata (ycnt, 3} ) then 

if (alldata (xcnt, 3) .It. alldata (ycnt, 4} ) mincnt-mincnt+1 
elseif (alldata (xcnt, 3} .gt. alldata (ycnt, 3) ) then 

if (alldata (xcnt, 4 ) .gt. alldata (ycnt, 3} ) mincnt-mincnt+1 
endif 
endif 

if (mincnt .gt. mincnt2) minobs^ninxyrow+1 
endif 

c 

590 continue 
xcnt -ycnt 
ycnt-ycnt+1 

if (jstop .eq. 1) go to 600 
595 if (ycnt .gt. allcnt) then 

if (global .eq. 1) go to 600 
ycnt-1 
jstop-1 
endif 
go to 500 
c 

600 continue 

if (mincnt .eq. strmincnt) go to 999 
if (strmincnt .It. mincnt) then 
s t rmi nc nt -mi n cn t 
go to 470 
endif 
c 

999 continue 

write (*,*) ’total passes read - ',totpass 
if (nocnt .gt. 0) then 

write (*,*) 'will remove the following passes from processing' 
do 1010 i-1, nocnt 

write (*,*} nowant (i),l 
1010 continue 
endif 

if (type .eq. 2} write (*,*) 'new minimum observation cutoff, 

> * is -', minobs 

rewind (10) 
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c 

return 

end 

c 

c 

c 

subroutine track (nop, noc) 
integer nop, noc 

real radfac, x (400} ,y (400) , xadata (400, 4 ) , ybdata (400, 4 ) 

common /tplot/ x (400) , y (400) 

common /trunstat/ xadata (400, 4) , ybdata (400, 4} 


c subroutine description 

c track stores the lat and long coordinates of each 

c data point along a pass, these coordinates are then 

c used to plot with a graphics package, the track footprint 

c of the satellite. 

c NOTE: the lat and long values are converted to radian values 

c because the plotting package that i work with utilizes 

c radians. 


RADFAC-0. 017453293 

noc-noc+1 

do 300 j-1 , nop 

x(j) - 90.0 - xadata(j,l) 
y(j) - xadata ( j, 3) 

if (y ( j) .It. 0.0) y ( j) - yO) + 360.0 
x ( j) - x ( J) * radfac 
y(j> “ y ( j) * radfac 
300 continue 
C 

return 

end 
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program fourierld 
character*BO filename 

real xdata (4096) , ydata (4096) , xmean,ymean, minccin, 

> prcnt, delta, cuthi, cutlo, xlag, mlncc, maxcc, short, long, 

> maxccin, cxlag, strxdata (4096) 

integer xpassno,ypassno, zero, eight, file,xcol,xrow,ycol,yrow, 

> trnsf, lhb, cc,trnsb, npass, imean, cnwind, seven, 

> nwind, numfile,nxout, nyout, match, gfcnt , xnobs, ynobs 
complex xcdata (4096) ,ycdata (4096) 

common /rowcol/ xnobs, ynobs 

common /fftifft/ nobs, prcnt, imean, fold 

common /lhbflt/ delta, cuthi, cutlo, xlag, npass, nwind 

common /ccflt/ mlncc, maxcc, match, minccin, maxccin, cnwind, cxlag 

common /reals/ xdata, ydata 

common /comps/ xcdata, ycdata 


c 

c program description 

c 

c fourierld is an all encompassing fourier analysis program! 

c subroutines include the fft for forward and inverse situations, 

c a bandpass filter which can be adjusted to perform low, high and 

c bandpass filtering of wave numbers and a correlation coefficient 

c filter which 2 eros out wavenumbers according to correlation 

c coefficients, both the bandpass filter and the correlation 

c coefficient filter provide the user with several windowing options 

c (as well as no windowing option) to smooth wavenumbers prior 

c to inverse transformation, both filters use the same subroutine 

c to window in the TIME (real number data) domain, with respect to 

c run time considerations: if many different datasets are submitted 

c at the same time to the program, it will still calculate the same 

c BANDPASS windowing function for each dataset every time it 

c encounters a new dataset, since this windowing function need only 

c be calculated once, it causes the program to do needless work, i 

c hope to soon remedie this little time consuming "bug", big note of 

c caution: the windowing function will change with each new dataset 

c for the CORRELATION FILTER and therefore, leave it alone! ! 

c 

c NOTE: ANY fourier analysis routine can be inserted 

c to this program as a subroutine, maybe i'll put in 

c such features as upward continuation, etc., 

c NOTE: the only data variables absolutely necessary as INPUT are 

c the number of observations of input profile, the remaining 

c variables; zero, mean, pass-number and eight, are not needed, 

c but, mean can be an OUTPUT if desired, 

c 

c updates: 

c 30 Jan 91 

c this update pertained to removing calls to differing fft2d 

c subroutines so that now all calls are to the same fft2d 

c subroutine, and more importantly, now the fft2d routines 

c will handle 1 row of data so that the bandpass filter works 

c correctly, and even more importantly the zero filling option 

c now zero fills such that the data is located in the middle 

c of all those wonderful zeros, and for those of you who are 

c really into this, you can now fold out a percentage of the 

c edge of your data, smooth the folded out part to zero, fft, 

c filter, and ifft such that edge effects are minimized, 

c ohh boyy! ! 

c 

c 9 jul 92: 

c major revisions changing code from two-dlmenslonally based 

c ffts to one-dimensional ffts. revisions Include removal of 

c subroutines transpo and store, major changes to subroutines 

c fft2d (which is now known as fftld) , datwnd, bndpas and 

c window, now there is no longer a need for transposing the 

c arrays so that run time should be decreased, 

c NOTE: i removed a great deal of comments at the beginning of 

c the subroutines, all removed comments discussed the 

c two dimensional sense of the routine, i added comments 

c dealing specifically with the one dimensional changes. 


c 

c 

write <*,*) '0 IF YOU HAVE A FILE OF ALL VARIABLES' 
write (*,*) *1 IF YOU WANT TO TYPE THEM INTERACTIVELY — ha ha' 
read (*,*) file 
if (file .eq. 0) then 
write (*,9988) 

9980 format ('USE THE FOLLOWING ORDER FOR INPUT FILE*/, 

> 'IF VARIABLE DOES NOT APPLY INPUT ANY BOGUS NUMBER'/, 

> *numfile'/, 

> *lhb cc'/, 

> ‘nobs fold prcnt imean'/, 

> 'delta short long npass'/, 

> 'nwind xlag*/ 

> 'mince maxcc match minccin maxccin cnwind cxlag'/ 

> 'isub'/J 

write (*,*) 'INPUT FILE OF VARIABLES' 
read (*,9990) filename 

open (22, file-filename, form- ' formatted' , status- 'old' ) 
go to 100 
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elseif (file ,eq. 1) then 
go to 50 

elseif (file .ne. 0 .or. file ,ne. 1) then 

write (*,*) ' HEY HEY HEY ITS BAD FILE NUMBER AND YOU GOT 1 
write (*,*) 'TO MAKE A NEW CHOICE TOOOOOOO — to the tune of' 
write (*,*) * fat albert' 
go to 999 
endif 

50 continue 

write (*,9989) 

9989 format ('1 IF YCU HAVE ONLY ONE FILE TO BE FOURIERED'/, 

> '2 IF YOU HAVE TWO FILES TO BE COMPARED * ) 
read (*,*) numfile 

write (*,9991) 

9991 format (/'l FOR ONLY LOW-HIGH-BAND FILTER THE DATA'/, 

> '2 FOR L-H-B FILTER THEN C-C FILTER THE DATA'/, 

> '3 FOR L-H-B THEN C-C THEN L-H-B FILTER THE DATA'/, 

> *4 FOR C-C FILTER THEN L-H-B FILTER THE DATA'/, 

> '5 FOR C-C THEN L-H-B THEN C-C FILTER THE DATA'/, 

> *6 DO NOT FILTER THE DATA'//, 

> *1 FOR ONLY CORRELATION COEFICIENT FILTER THE DATA'/, 

> *2 DO NOT C-C FILTER THE DATA'/, 

> 'choose 2 if 5 or less was chosen above'//, 

> 'lhb cc') 

read (*,*) lhb, cc 

write (*,9992) 

9992 format ('THE FOLLOWING REFERS TO FFT AND IFFT' //, 

> 'NUMBER OF OBSERVATIONS FOR FFT ARRAY'/, 

> 'AT A POWER OF 2: (256) (2 16 32 64 128 256 etc)'//, 

> 'PERCENT OF DATA TO BE FOLDED OUT (0.1 TO 99.9)'/, 

> 'PERCENT OF EACH EDGE OF INPUT ARRAY OR FOLDED'/, 

> 'OUT ARRAY TO BE SMOOTHED TO ZERO (0.1 TO 49.9) '//, 

> '0 DO NOT ADD MEAN TO IFFT DATA'/, 

> '1 ADD MEAN OF INPUT DATA TO OUTPUT IFFT DATA'/, 

> 'nobs fold prcnt imean') 

read ( * , * ) nobs , fold, prcnt , imean 

if (nobs .gt. 4096) then 
write (*,8999) nobs 

8999 format (lx, ' SORRY • , 16, lx, • IS GREATER THAN 4096 THE' , 

> ‘SIZE OF ARRAYS SET'/' IN THE SOURCE CODE ', 

> ‘YOU NEED TO ACCESS SOURCE CODE AND MAKE CHANGES') 
go to 999 

endif 


c 


c 

c 

c 


if (lhb .It. 6} then 
write (*,9993) 

9993 format ('DELTA GRID INTERVAL IN MAP UNITS (0.33 degrees)'/ 

> 'SHORT SHORTEST WAVELENGTH TO BE PASSED*/ 

> * MUST BE AT LEAST 2* DELTA (0.66 degrees)*/ 

> 'LONG LONGEST WAVELENGTH TO BE PASSED'/ 

> ' MUST BE LARGER THAN SHORT ...no kidding!'/ 

> 'CUTHI HIGHEST WAVENUMBER TO PASSED ,LE . NYOUIST'/ 

> ' CUTLO LOWEST WAVENUMBER TO BE PASSED .GE. 0.0 AND'/ 

> * .LT. CUTHI'// 

> ' NPASS -1 TO REJECT WAVELENGTHS BETWEEN SHORT'/ 

> ' AND LONG'/ 

> ' 1 TO PASS WAVELENGTHS BETWEEN SHORT AND'/ 

> ' LONG ' // 

> ' NOTE : WAVENUMBER - 1 /WAVELENGTH AND IS '/ 

> 1 CALCULATED BY THE PROGRAM'/ 

> ' INPUT ORDER IS DELTA SHORT LONG NPASS') 
read (*,*) delta, short, long, npass 

write (*,9994) 

9994 format (’ NWIND TYPE OF WINDOW TO APPLY'/ 

> ' - 0 GIVES NO WINDOW'/ 

> ' - 1 RECTANGULAR WINDOW'/ 

> ' - 2 BARTLETT WINDOW (TRIANGULAR)'/ 

> ' - 3 HAMMI NG-TUKEY WINDOW*/ 

> ' - 4 PAR2EN WINDOW'/ 

> ’ XLAG SMOOTHING PARAMETER FOR WINDOWING IDEAL'/ 

> ' FILTER IN SPATIAL DOMAIN (95.0) (is disabled if'/ 

> ' no window was chosen above).'// 

> ' nwind xlag') 

read (*,*) nwind, xlag 
endif 


if (lhb .ge. 2 .and. lhb ,le. 5 .or. cc .eq. 1) then 
write (*,9995) 

9995 format ('WHAT IS THE MINIMUM CORR COEF TO BE PASSED : (0. 3) ' /, 

> 'WHAT IS THE MAXIMUM CORR COEF TO BE PASSED: <1 . 0) ' /, 

> *0 DO NOT CHECK MATCH OF PASSNOS'/, 

> '1 FOR PROGRAM TO CHECK MATCH OF PASSNOS'/, 

> 'MINIMUM INPUT CC WITHOUT WRITING WARNING'/, 

> 'MAXIMUM INPUT CC WITHOUT WRITING WARNING'/, 

> ' CNWIND TYPE OF WINDOW TO APPLY'/ 

> - 0 GIVES NO WINDOW'/ 
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> ' - 1 RECTANGULAR WINDOW'/ 

> - 2 BARTLETT WINDOW (TRIANGULAR)'/ 

> ' - 3 HAM4I NG-TUKE Y WINDOW'/ 

> ' - 4 PARZEN WINDOW'/ 

> ' CXLAG SMOOTHING PARAMETER FOR WINDOWING IDEAL'/ 

> ' FILTER IN SPATIAL DOMAIN (95.0) (is disabled if'/ 

> ' no window was chosen above).'// 

> 'mince maxcc match minccin maxccin enwind cxlag') 


read (*,*) mince, maxcc, match, minccin, maxccin, enwind, cxlag 
endif 

if (numfile .eq. 2) then 

write (*,*} 'AND FINALLY: 0 DO NOT SUBTRACT FILEl-FILEl (use 0) ' 
write (*,*) *1 TO WRITE A FILE OF TIME DOMAIN SUBTRACTION' 
write <*,*) 'OF FILE 3 - INPUT FILE 1 - OUTPUT FILE 1' 
read (*,*) isub 


c isub equals 1 if you want to subtract 

c the filtered portions of filel from the 

c input of filel. this option is not 


often used, 
endif 

go to 200 

100 continue 

read (22,*) numfile 

read (22,*) lhb, cc 

read (22,*) nobs, fold, prent, imean 

read (22,*) delta, short, long, npass 

read (22,*) nwind, xlag 

read (22,*) mince, maxcc, match, minccin, maxccin, enwind, cxlag 
read (22,*) isub 

200 continue 

write (*,*) 'all input files must have a header with:' 
write (*,*) 'row, column, zero, mean, pass number , eight ' 
write (*,*) 'zero... can be bogus but row and col are necessary' 
write (*,*) 'INPUT FILE 1 (do not put guide function file here)' 
read (*,9990) filename 
9990 format (aBO) 

open (10, file-filename, status- ' old' , form-’ unformatted' ) 
if (numfile .eq. 2) then 

write (*,*) 'INPUT FILE 2 (or the guide function file)' 
read (*,9990) filename 

open (11, file-filename, status- * old’ , form- ' unformatted' ) 
endif 

write {*,*} 'OUTPUT OF FILE 1' 
read (*,9990) filename 

open (20, file-filename, form- ' unformatted' ) 
if (numfile .eq. 2) then 

write (*,*) 'OUTPUT OF FILE 2* 
read (*,9990) filename 

open (21, file-filename, form- ' unformatted* ) 
endif 

write (*,*) 'OUTPUT FILE OF STATISTICS AND INFORMATION' 
read (*,9990) filename 

open (25, file-filename, form- ' formatted' ) 
if (isub .eq. 1) then 

write (*,*) 'OUTPUT FILE 3 OF SUBTRACTION* 
read (*,9990) filename 

open (23, file-filename, form-' unformatted* ) 
endif 

if (lhb .It. 6) then 
cuthi-1 .0/short 
cutlo-1 .0/long 
RCUTLO-999999. 99 

IF (CUTLO .GE. 0.0000001 ) RCUTLO- 1.0/CUTLO 
RCUTHI-1 . 0/CUTHI 
WAVLEN-2 . 0*DELTA 
FNQl-1 . 0/WAVLEN 

WRITE (25,9907) FNQ1, WAVLEN, CUTLO, RCUTLO, CUTH I, RCUTHI 
9987 FORMAT ( ' NYQUIST WAVENUMBER -',F10.5, ' CYCLES PER DATA INTERVAL'/, 

> 'NYQUIST WAVELENGTH - \F10.5, ' LENGTH INTERVALS'/, 

> 'LOW WAVE# CUTOFF OF IDEAL FILTER - \F10.5, 

> ' CYCLES PER DATA INTERVAL '/,F15.5, 

> ' WAVELENGTH EQUIVALENT'/, 

> 'HIGH WAVE# CUTOFF OF IDEAL FILTER - \F10.S, 

> ' CYCLES PER DATA INTERVAL '/,F15.5, 

> ' WAVELENGTH EQUIVALENT',//) 

endif 

gfcnt-0 
210 continue 

read (10, end-999) xrow, xcol, zero, xmean, xpassno, eight 

xnobs-xrow 

do 1-1, xrow 
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230 


c 


c 


c 


c 

c 

c 

c 

c 

c 

500 


530 


570 


c 


c 

999 


c 

c 

c 


read (10) xdata(i) 
enddo 

if {numfile .eq. 2) then 

read (ll,end**999) yrow, ycol, zero, yraean, ypassno, seven 
if (seven .eq. 7777) go to 500 
ynobs-yrow 
do 1-1, yrow 

read (11) ydata(i) 
enddo 
endif 

if (isub .eq. 1) then 
do i-1 , xrow 

strxdata (i) -xdata (i) 
enddo 
endlf 

xmean-0.0 

call forwardft (1, xmean, xpassno) 
yntean-0.0 

If (nunvfile .eq. 2) call forwardft (2, ymean, ypassno) 

if (lhb .le. 3) then 
call filter (1) 

if (numfile .eq. 2) call filter (2) 
endLf 

if (lhb .ge. 2 .and. lhb .le. 5 .or. cc .eq. 1) then 
call correlate (xpassno, ypassno) 
endlf 


if (lhb .ge. 3 .and. lhb .le. 5) then 
call filter (1) 

if (numfile .eq. 2) call filter (2) 
endlf 

if (lhb .eq. 5) call correlate (xpassno, ypassno) 
call inverseft (1 , xmean, xpassno) 

If (numfile .eq. 2) call inverseft ( 2, ymean, ypassno) 


write (20) xrow,xcol, zero, xmean, xpassno, eight 
do i-1 , xrow 

write (20) xdata(i) 
enddo 

if (numfile .eq. 2) then 

write (21) yrow, ycol, zero, ymean, ypassno, seven 
if (seven .eq. 7777) then 
gfcnt-gfcnt* 1 
go to 570 
endlf 

do i-l,yrow 

write (21) ydata(i) 
enddo 

if (isub .eq. 1) then 

if (seven .eq. 7777) then 

write (23) xrow, xcol, zero, xmean, xpassno, eight 
do i-1, xrow 

write (23) xdata(i) 
enddo 

elseif (seven .ne. 7777) then 

write (23) xrow, xcol, zero, xmean, xpassno, seven 
do i-1, xrow 

write (23) ( strxdata (i) -xdata (i) ) 
enddo 
endif 
endlf 
endif 

go to 210 

continue 

if (gfcnt .gt. 0} 

► write (*,*) 'total passes without a guide function gfcnt 
close (10) 
close (11) 
close (20) 
close (21) 
close (22) 
close (25) 
stop 
end 


subroutine forwardft (num, mean, pas sno) 
integer num, xnobs, y nobs, xy nobs, nobs, pas sno 
real xdata (4096) ,ydata (4096) ,prcnt,mean 
complex xcdata (4096) ,ycdata (4096) 
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common /fftifft/ nobs, prcnt, imean, fold 
common /rowcol/ xnobs,ynobs 
common /reals/ xdata,ydata 
common /comps/ xcdata, ycdata 
COWON H (4096) 

DIMENSION X (2, 4096) 

COMPLEX H 

double precision TSUM 
EQUIVALENCE (X (1, 1) ,H (1) ) 

TSUM-0.D0 

if {num .eq. 1> then 
xynobs -xnobs 
do i-1, xynobs 

x(l,i) - xdata(i) 
tsum-tsum+x (l,i) 
enddo 

elseif (num .eq. 2) then 
xynobs-ynobs 
do i-1, xynobs 

x(l,l) - ydata(i) 
tsum-tsum+x ( 1 , i > 
enddo 
endif 


subroutine description 


REQUIRED SUBROUTINES : 

FFTlD, FORK, DATWND 
DIMENSIONING REQUIREMENTS : 

X (2,N) WHERE N IS THE NUMBER OF COLUMNS AND ROWS OF THE 

H (N) OUTPUT TRANSFORMED MATRIX. N MUST BE AN INTEGRAL 

POWER OF TWO (2,4,8,16...). 

NOTE : DIMENSIONS IN EVERY SUBROUTINE MUST BE 
SET EQUAL TO DIMENSIONS IN MAIN PROGRAM. 

AUTHOR : SUBROUTINES FFT2D AND FORK ARE MODIFIED FROM JON REED, 
PURDUE UNIVERSITY, DECEMBER 1980. 

ALL OTHER CODE WRITTEN BY: 

JEFFREY E. LUCIUS 

GEOPHYSICAL INTERACTIVE COMPUTING LABORATORY 
DEPARTMENT OF GEOLOGY AND MINERALOGY 
THE OHIO STATE UNIVERSITY 
COLUMBUS, OHIO 43210 

MARCH 25, 1985 (REVISED DEC 5, 1986) 


revised once again for DEC workstations on 6 APR 90 so that 
that this beast is actually user friendly. 

These revisions will almost always be lower case letters. 

revised again ( judas priest this is getting old) on 
1 AUG 90 into this present format of all fourler programs 
combined into this program, for a full listing of all 
comments in the 6 APR 90 version, see that version, no 
kidding. 


IF (2**INT (ALOG (FLOAT (nobs) ) /ALOG (2 . 0) +0. 01 ) .NE.nobs) THEN 
WRITE (6, 1030) 

STOP 

ENDIF 

CALCULATE AND REMOVE THE MEAN 

XMEAN1 -TSUM/ FLOAT (xynobs ) 

DO IY-1, xynobs 

X (1, IY) -X (1, IY) — XMEANl 
enddo 

WRITE (25,1020) XMEANl 

, WINDOW THE EDGES VIA DATWND 

CALL DATWND (PRCNT, xynobs, nobs, fold) 

.MATRIX IS NOW ZERO FILLED TO NX OUT BY NY OUT SIZE 
CALCULATE AND REMOVE THE MEAN INTRODUCED BY TAPERING 

TSUM-0.D0 
DO IY-1 , nobs 

TSUM-TSUM+X (1, I Y) 
enddo 

XMEAN 2 -TSUM/ FLOAT (nobs) 

DO IY-1, nobs 
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X (1 , IY) -X (1, IY) -XMEAN2 
enddo 

c WRITE (25, 1020) XMEAN2 

XMEAN-XMEAN2+XMEAN1 
c WRITE (25, 1080) XMEAN 

writ® (25,*) pass no, xmeanl, xmean2, xmean 
C 

C TRANSFORM DATA TO THE WAVENUMBER DOMAIN 

C 

CALL FFTlD (nobs, -1 ) 

C 

mean-xmean 
if (num .eq. 1) then 
do ix-1, nobs 

xcdata(ix) - h(ix) 
enddo 

elseif (num .eq. 2) then 
do ix-1, nobs 

ycdata(ix) - h(ix) 
enddo 
endif 
c 

return 

c 

1020 FORMAT ('MEAN REMOVED ',F15.7) 

1030 FORMAT (1H , ‘nobs MUST BE A POWER OF 2: SPA2FRQ FATAL 1 ) 

1080 FORMAT ( * TOTAL MEAN REMOVED ' ,F15.7) 

C 

END 

C 

£******** ********************* ****************************************** 
C 

SUBROUTINE FFTlD (nobs,NSIGN) 

********************************************************************** 


"FFTlD" PERFORMS BOTH A FORWARD OR INVERSE FAST FOURIER 
TRANSFORM. "FFTlD" IS THE DRIVER THAT PASSES THE CORRECT VECTORS 
TO "FORK" WHICH PERFORMS THE ACTUAL TRANSFORMING. 

THE DIMENSIONING OF "H" MUST BE THE SAME AS IN THE MAIN PROGRAM 

"nobs" - NUMBER OF fft observations IN DATA MATRIX 
"NSIGN" - DIRECTION OF DESIRED TRANSFORMATION 

-+1 INVERSE TRANSFORM (FREQUENCY TO SPATIAL) 

—1 FORWARD TRANSFORM (SPATIAL TO FREQUENCY) 

********************************************************************* 


COMMON H (4096) 

COMPLEX H 

SIGNI -FLOAT (NSIGN ) 

IF (IABS (NSIGN) .NE.l) THEN 
WRITE (6, 105) 

STOP 

ENDIF 

CALL FORK (nobs, H, SIGNI ) 

RETURN 

05 FORMAT (5X, * "NSIGN" MUST EQUAL +1 OR -1 FOR "FFT2D", FATAL') 

END 

******************************************************************£££** 
SUBROUTINE FORK (LXX, CX, SIGNI ) 

FAST FOURIER TRANSFORM, MODIFIED FROM CLAERBOUT, J.F., FUNDAMENTAL * 
OF GEOPHYSICAL DATA PROCESSING, MCGRAW-HILL, 1976 * 

FORK USES COOLEY-TUKEY ALGORITHM. 

"CX" - DATA VECTOR TO BE TRANSFORMED * 

"LXX" - LENGTH OF DATA VECTOR "CX" TO BE TRANSFORMED, * 

MUST BE A POWER OF 2 (LXX-2** INTEGER) * 

"SIGNI"- DIRECTION OF DESIRED TRANSFORMATION * 

-+1. INVERSE TRANSFORM (FREQUENCY TO SPATIAL) * 

— 1. FORWARD TRANSFORM (SPATIAL TO FREQUENCY) * 

NORMALIZATION PERFORMED BY DIVIDING BY * 

DATA LENGTH UPON THE FORWARD TRANSFORM. * 

*******************************t***t*******************H********H**** 

COMPLEX CX ( LXX ) , CW, CTEMP , CON2 
C 

LX -LXX 

LXH-LX/2 

J-l 

DO 103 1-1, LX 
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IF (I.LT.J) THEN 
CTEMP -CX (J) 

CX(J)-CX {1} 

CX (I) -CTEMP 
ENDIF 
M-LXH 

102 IF (J.GT.M) THEN 

J-J-M 

M-M/2 

IF (M.GE.l) GO TO 102 
ENDIF 
J-J+M 

103 CONTINUE 
L-l 

104 ISTEP-2*L 

CON2- (0.0, 3. 14159265) /FLOAT (L)*SIGNI 
DO 105 M-1,L 

CW-CEXP (CON2* FLOAT (M-l ) ) 

DO 105 I-M, LX / I STEP 
CTEMP-CW*CX(I+L) 

CX(I+L)-CX(I)-CTEMP 

105 CX ( I ) -CX ( I ) + CTEMP 
L— I STEP 

IF (L.LT.LX) GO TO 104 
IF (SIGNI.GT.0.0) RETURN 
SC -1. /FLOAT (LX) 

C 

DO 106 1-1, LX 

106 CX(I)«CX(I)*SC 
C 

RETURN 

END 

C 

£**********★******************************+*********************+******* 

C 

SUBROUTINE DATWND (PRCNT, xynobs, nobs, fold) 
integer xynobs 
C 

£*******************★★+★************★****************+*+*+*************+ 

c * 

C "DATWND" MULTIPLIES THE INPUT F(l, xynobs) BY A HALF BELL OF A HAM4IN* 

C TUKEY WINDOW ON ALL EDGES AND ZEROS OUT THE REMAINDER OF THE * 

C (NX, NY ) ARRAY. * 

C * 

C "PRCNT" -PERCENTAGE OF DATA TO BE ALTERED IN SMOOTHING TO ZERO * 

C 0.0 .LT. "PRCNT" .LE. 50.0 * 

C 

c update 2 feb 91 

c datwnd has been considerably improved such that now the subroutine 
c performs three (count them, three !!) functions, one; a percentage 
c of the input matrix can be folded out. two; after folding out, 

c a new percentage of the folded out matrix (or regular data if 

c folding was not performed) can be smoothed to zero, three; the 

c manipulated data is centered within zeros to finish filling the 

c matrix to nx by ny size, because the actual data is now centered 
c within the transformed array, it is necessary to use the 

c do loops in subroutine inverseft to correctly extract the actual 

c data 
c 

C*********************************************************************** 

c 

dimension holdme (4096) 

COMMON F (2, 4096) 

C 

c fold out the data based on percentage 

c 

nxl-xynobs 

if (fold. gt. 0.0 .and. fold.lt. 100. 0) then 
KX-Int (fold* FLOAT (xynobs) /100. 0+0 . 5) 
if (kx+xynobs .gt. nobs) kx- (nobs-xynobs ) /2 
do i-1, xynobs 

holdme (i) -f (1 , i) 
enddo 

c fold out the observations 

do i-1, xynobs+kx+kx 

if (i . le .kx) f (l,i) -holdme (kx-i+1) 

if (i.gt.kx .and. i. le. (kx+xynobs) } f (1, i) -holdne (i-kx) 
if (i . gt . (kx+xynobs) ) f (1, i) -holdme ( (2*xynobs+kx+l-i ) ) 
enddo 

nxl-xynobs+2*kx 

endif 

c 

if (prcnt .gt .0.0 .and. prcnt . It . 50 .0} then 
KX-IFIX (PRCNT* FLOAT (NXl ) /100 . 0+0. 5 ) 

C 

IF(KX.NE.O) THEN 

RKXPI- 3 . 14 159265/FLOAT (KX) 

DO IX-1, KX 

FACTOR-0 . 5* (1 . 0+COS (FLOAT (KX-IX + 1 ) *RKXPI ) ) 

IXX-NX1-IX+1 

F (1, I XX) -F (1, IXX) * FACTOR 
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enddo 
EM) IF 

C 

c WRITE (25, 150) KX # KY 

write (25,*} kx,ky 
endif 
C 

C center and ZERO OUT REMAINDER OF ARRAY IF NECESSARY 

C 

nx half- (noba-nxl } /2 
do i-l,nxl 

holdme (i) -f (l,i) 
enddo 

do i-1, nxhalf 
f (l,i)-0.0 
enddo 

do I-nxhalf+1, nxhalf *nxl 
f (1 , i ) -holdme (i-nxhalf ) 
enddo 

do 1-nxhalf+nxl+l, nobs 
f (l,i)-0.0 
enddo 
c 

RETURN 

C 

150 FORMAT ( 1 smoothed* , 14 , ' values on both x edges'/, 

> • ' ,14, ' y ') 

c 

END 

c 

c 

c 

subroutine filter (num) 

integer num, npass, imean, n wind, nobs 

real prcnt,xlag, delta, cuthi, cutlo 

complex xcdata (4096) ,ycdata (4096) , cdata (4096) 

common /rowcol/ xnobs,ynobs 

common /fftifft/ nobs, prcnt, imean, fold 

common /comps/ xcdata, ycdata 

common /lhbflt/ delta, cuthi, cutlo, xlag, npass, nwind 
COMMON H (4096) 

COMPLEX H 

DIMENSION D1 (2, 4096) 

EQUIVALENCE (D1 (1, 1 ) , H (1 ) ) 
c 

if (num .eq. 1) then 
do i-1, nobs 

cdata (i) - xcdata (i) 
enddo 

elseif (num .eq. 2) then 
do 1 -1 , nobs 

cdata (i) - ycdata (i) 
enddo 
endif 

***********★***************★★**************+************************* 


PROGRAM BANDPASS 

PROGRAM BANDPASS PERFORMS HIGH, LOW, OR BANDPASS WAVENUMBER 
FILTERING OF UNIFORMLY GRIDDED ARRAYS. AN IDEAL FILTER 
IS CONSTUCTED IN THE WAVENUMBER DOMAIN, WINDOWED IN THE SPACE 
DOMAIN, THEN TRANSFORMED BACK INTO THE WAVENUMBER DOMAIN TO BE 
MULTIPLIED BY THE INPUT TRANSFORM. 

REQUIRED SUBROUTINES : 

BNDPAS, FFT2D, FORK, STORE, WINDOW 

, DIMENSIONING REQUIREMENTS : 

D1 (2, N) WHERE N IS THE NUMBER OF observations OF THE 

H (N) INPUT AND OUTPUT TRANSFORMED MATRIX. N MUST BE AN 

INTEGRAL POWER OF TWO (2,4,0,16...). 

NOTE : DIMENSIONS IN EVERY SUBROUTINE MUST BE 
SET EQUAL TO DIMENSIONS IN MAIN PROGRAM. 

.AUTHOR : JON REED, PURDUE UNIVERSITY, DECEMBER 1980. 

REVISIONS BY STEVE MATESKON AND JEFF LUCIUS, 

OHIO STATE UNIVERSITY, JULY 1984. 


this program, like others in the fft series, has been updated 
to the DEC workstation system and now the program is actually 
usable to just about anybody! revised 21 apr 90 

well, like the other programs in this package, this has been 
updated on 4 AUG 90. few comments have been removed - mainly 
those comments about i/o operations not necessary to this 
package have been removed. 
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update: 2 feb 90, removed need for cstore array 


****************************************************** **************** 


CREATE IDEAL CONTINUATION FILTER AND STORE IN ARRAY H 
CALL BNDPAS (CUTLO, CUTHI, NPASS, DELTA, nobs) 

CREATE SMOOTHED FILTER 

IF (XLAG.GT.0.0 .AND. XLAG.LE. 100.0) THEN 
I F (NWIND . GT . 0 . AND . NWIND . LE . 4 ) THEN 
CALL FFT1D (nobs,l) 

CALL WINDOW (nobs, XLAG, NWIND) 

CALL FFTlD (nobs,-!) 

ENDIF 

ENDIF 

WRITE FILTER (WAVENUMBER DOMAIN) ONTO UNIT 30 IF IOFIL - 1 

IF (IOFIL.EQ.l) THEN 

WRITE (30,*) nobs, IZERO,XMEAN 
WRITE (30,*) <H (IX) , IX-1, nobs) 

ENDIF 

if (num .eq. 1) then 
do i-l,nobs 

xcdata(i) - cdata (1) *h (i ) 
enddo 

elseif (num .eq. 2) then 
do i-l,nobs 

ycdata(i) - cdata (i ) *h (i ) 
enddo 
endif 

return 

end 


********************************************************************** 
SUBROUTINE BNDPAS (CCUTLO, CCUTHI , NPASS, DELTA, nobs ) 


"BNDPAS" CALCULATES THE WAVE# RESPONSE OF AN IDEAL BANDPASS 
FILTER OF A (nobs) MATRIX. ARRAY "H" MUST BE DIMENSIONED THE 
SAME AS IN THE MAIN PROGRAM 


"CCUTLO" 

"CCUTHI" 

"NPASS" 


"DELTA" 

nobs 


LOWEST WAVE# TO BE PASSED, GE 0.0 
HIGHEST WAVE# TO BE PASSED, LE NYQUIST 
SWITCHES EITHER A PASS OR REJECTION BETWEEN 
"CUTLO" 4 "CUTHI" 

—1 REJECT WAVENUMBERS BETWEEN THE 2 WAVENUMBERS 
- 1 PASS WAVENUMBERS BETWEEN THE 2 WAVENUMBERS 
DATA GRID INTERVAL, IN MAP UNITS 
number of fft observations 




COMMON H (4096) 

COMPLEX H, ZERO, ONE 

CUTHI -CCUTHI 
CUTLO -CCUTLO 
RCUTLO-999999 .99 

IF (CUTLO. GE. 0.0000001 ) RCUTLO- 1.0/CUTLO 
KCUTHI-1 .0/CUTHI 
WAVLEN-2 .0*DELTA 
FNQ1-1. 0/WAV LEN 

WRITE (25,112) FNQ1,WAVLEN, CUTLO, RCUTLO, CUTHI, RCUTH I, NPASS 

IF (IABS (NPASS) .NE.l) THEN 
WRITE (6, 151) 

STOP 
ENDIF 

I F (CUTHI . GT . FNQl . OR. CUTHI . LE . CUTLO . OR . CUTLO . LT . 0 . 0 ) THEN 
WRITE (6, 151) 

STOP 
ENDIF 
C 

NXX-nobs+2 
NX2- (nobs/2) +1 
ZERO - (0.0, 0.0) 

ONE - (1.0, 0.0) 

IF (NPASS. NE. 1) THEN 
ZERO - (1. 0,0.0) 

ONE - (0. 0,0.0) 

ENDIF 
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CLOWX -FLOAT (NX 2) *WAVLEN+ CUTLO 
CHIX -FLOAT (NX2) *WAVLEN*CUTHI 
C 

C "ZERO" OUT THE entire ARRAY 

C 

DO IX-1 , nobs 
H (IX) - ZERO 
enddo 
C 

C OPERATE ON ROWS WHERE WAVENUMBERS ARE .L£. CUTLO 

C 

MINS-1 

MAXS-NX2 

IF (CUTLO. GT. 0.000001) MINS- int (clowx + 2.0001) 

IF (FNQ1-CUTHI.GT. 0.000001) MAXS-int (chix + 1.0001) 
if (mins .le. maxs) then 
DO IX-MINs,MAXs 
H (NXX-IX) - ONE 
H (IX) - ONE 
enddo 
ENDIF 
C 

RETURN 

C 

112 FORMAT (/IX, 'NYQUI ST WAVENUMBER - 1 , F10 . 5, 'CYCLES PER DATA INTERVAL' 

> /IX, 'NYQUI ST WAVELENGTH - \F10.5, ' LENGTH INTERVALS'/ 

> IX, 'LOW WAVE# CUTOFF OF IDEAL FILTER - *,F10.5, 

> ' CYCLES PER DATA INTERVAL* , 3X, FI 5 . 5, ' WAVELENGTH EQUIVALENT'/ 

> IX, 'HIGH WAVE# CUTOFF OF IDEAL FILTER - ',F10.5, 

> ' CYCLES PER DATA INTERVAL' , 3X, Fl 5 . 5, 

> * WAVELENGTH EQUIVALENT ', /IX, 'NP ASS- Ml//) 

151 FORMAT (5X , ' IMPOSSIBLE FILTER CONSTRUCTION IS SPECIFIED. FATAL*) 

C 

END 

C 

C 

c*********************************************************************** 

c 


SUBROUTINE WINDOW (nobs, XLAG,NWIND> 

C 

C************************************************************+********** 
C "WINDOW" PERFORMS 1 -DIMENSION WINDOWING OVER the DATA ARRAY 
C EACH QUAD. IS SEPERATELY WINDOWED. THE 1.0 COEFFICENT IS ALWAYS 
C THE OUTER MOST CORNER OF THE ARRAY. 

C 

C "nobs" 

C "XLAG" 

C 
C 
C 
C 

c 
c 
c 

C "NWIND" 

C 
c 
C 

c 
c 
c 

c ********************************************************************** 

c 


- NUMBER OF observations IN DATA MATRIX 

- SMOOTHING PARAMETER FOR WINDOWING IDEAL FILTER IN SPATIAL * 

DOMAIN. DETERMINES WHAT PERCENTAGE OF DATA IS WINDOWED * 
(nobs*XLAG/100 .0) THE REMAINDER IS SET TO 0.0. I.E. THE 
SMALLER "XLAG" THE SMOOTHER THE WINDOWING. * 

"XLAG" MUST BE .GT. 0.0 .AND. LE. 100.0 FOR WINDOWING * 

VALUES OUTSIDE OF THIS RESULTS IN NO WINDOWING * 

THE SMALLER THE "XLAG" THE SMOOTHER THE FILTER. * 

* 

- TYPE OF WINDOW TO APPLY * 

-0 GIVES NO WINDOW * 

-1 gives a rectangular window 

-2 GIVES BARTLETT WINDOW (TRIANGLE WINDOW) * 

-3 GIVES KAM-IING-TUKEY WINDOW * 

-4 GIVES PARZEN WINDOW * 


COMMON H (4096) 
COMPLEX H 


LAG-FLOAT (nobs ) *XLAG/200 .0+0.5 
LAG-AMAX0 (LAG , 2 ) 

PI-3.14159265 
NXX-nobs+2 
NX2- (nobs/2) +1 
XNXR-FLOAT (NX 2 ) 

XNX-1 , 0/FLOAT (NX 2) 


RADIUS-FLOAT (LAG ) *XNX 
RADI -1.0/ RADIUS 
RAD2- RADI US* RADIUS 
C 

C APPLY RECTANGULAR WINDOW TO FILTER 


IF (NWIND. EQ. 1 ) THEN 

MAX-int (RADIUS*XNXR+1 . 0001 ) 

LL-MAX+1 

DO II-LL, NX2 

H(NXX-II)-(0. 0,0.0) 

H (II) - (0.0, 0.0) 
enddo 

c WRITE (25, 660) XLAG, LAG 

RETURN 
C 
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c 

c 


APPLY BARTLETT WINDOW TO FILTER 


253 

C 


255 

C 

c 

C 

c. . . 
c 


353 

C 


355 

C 

c 

C 

c. . 
c 


c 


453 

C 


457 


455 

C 

c 

C 

C.. 

c 

c 

c 

c 

660 

661 

662 

663 

664 
C 


ELSEIF (NWIND. EQ. 2) THEN 

MAX-RADIUS*XNXR+1 . 0001 
I F (MAX . GE . 2 ) THEN 
DO 253 LL-2 , MAX 

XI -FLOAT (LL-1 ) ‘XNX 
FACTOR-1 . 0-XI * RADI 
H(LL)-H(LL) ‘FACTOR 
MX-NXX-LL 

H (MX) -H (MX) ‘FACTOR 
END IF 

LL-MAX+1 

DO 255 II-LL,NX2 
H(NXX-II)- (0.0,0.0) 

H (ID— <0. 0,0.0) 

WRITE (25, 661) XLAG, LAG 
RETURN 

APPLY HAmiNG-TUKEY WINDOW TO FILTER 

ELSEIF (NWIND. EQ. 3) THEN 
PI RADI -PI ‘RADI 
MAX-RAD IUS*XNXR+1 . 0001 
IF (MAX.GE. 2) THEN 
DO 353 LL-2, MAX 

XI-FLOAT (LL-1 ) *XNX 
FACTOR-0.5* (1 . O+COS (PIRADI ‘XI ) ) 

H(LL)-H(LL) ‘FACTOR 
MX-NXX-LL 
H (MX ) — H (MX) ‘FACTOR 
END IF 

LL-MAX+1 

DO 355 II-LL, NX2 
H(NXX-II)- (0.0,0. 0) 

H (II)- (0. 0,0.0) 

WRITE (25, 662) XLAG, LAG 
RETURN 

.APPLY PARZEN WINDOW TO FILTER 

ELSEIF (NWIND. EQ. 4) THEN 
MAX-RAD IUS*XNXR+1 .0001 
MAX2-SQRT (RAD2/4 .0) ‘XNXR+1 . 0001 
FACTOR- 1.0- 6.0* ( (XI * RAD I ) “2- (XI ‘RADI ) * *3) 

H (1) -H (1) ‘FACTOR 

IF (MAX2.GE.2) THEN 
DO 453 LL-2, MAX2 
XI-FLOAT (LL-1 ) *XNX 

FACTOR- 1 .0-6.0* ( (XI*RADI) “2- (XI ‘RADI ) ** 3) 

H(LL)-H(LL) ‘FACTOR 
MX-NXX-LL 
H (MX) -H (MX) ‘FACTOR 
ENDIF 

KOUNT-MAX 2 + 1 
DO 457 LL-KOUNT, MAX 
XI-FLOAT (LL-1 ) ‘XNX 
FACTOR-2 . 0* (1.0- (XI*RADI) )“3 
H(LL)-H(LL> ‘FACTOR 
MX=NXX-LL 
H (MX)-H (MX) ‘FACTOR 
LL-MAX+1 

DO 455 II-LL, NX2 
H (NXX-I I)- (0.0, 0.0) 

H(II)-(0. 0,0.0) 

WRITE (25, 663) XLAG, LAG 
RETURN 

.DO NOT APPLY A WINDOW TO FILTER 

ELSEIF (NWIND. EQ.0) THEN 
WRITE (25, 664) 

ENDIF 

RETURN 

FORMAT (‘RECTANGULAR WINDOW USED XLAG- * , F7 . 3, 4X, ' LAG- \I5) 
FORMAT ('BARTLETT WINDOW USED XLAG- ' , F7 . 3, 4X, • LAG- • , 1 5) 
FORMAT CHANMNG-TUKEY WINDOW USED XLAG- ' , F7 . 3, 4X, ' LAG- ',15) 
FORMAT ('PARZEN WINDOW USED XLAG- ' , F7 . 3, 4X, ' LAG- ',15) 

FORMAT ('NO WINDOWING HAS BEEN APPLIED ; XLAG- *,F7.3) 

END 
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subroutine correlate (xpassno,ypassno) 
integer xnobs, ynobs, nobs, match, xpassno, ypassno, 

> zeroent (4096) , cnwind 
real mince, roaxcc, ccwinout,prcnt, 

> pctpr3,pctpr4,minccin,maxccin,cxlag 
complex h (4096 ), powers, power 6, totpwr 
COMPLEX X (4096), Y (4096), zero, 

> POWER! , PCWER2 , P0WER3, P0WER4 , XPGWER, TPOWER 
REAL CCOEF, CCIN, CCOUT 

DATA ZERO/ (0.000000,0.000000)/ 
common /row col/ xnobs,ynobs 
common /comps/ x, y 

common /ccflt/ mi ncc, max cc, match, mi nccin, max coin, cnwind, cxlag 
common /fftifft/ nobs, pr cn t, imean, fold 
common h 


subroutine description 

correlate finds the correlation coefficient between each 
wavenumber component of the two input arrays, each cc is 
normalized to range between -1.0 through 0.0 to 1.0. the 
cc is the cosine of the phase angle difference between two 
wavenumber components. 

revisions: 

well, by now you know the story... revised 4 AUG 90 
i've added the windowing functions available from the 
bandpassing subroutines to this cc-filter. try them if 
you like! 

updates 1 feb 91: change calculation of correlation 

coefficient from a summation based formula to the cosine of 
the phase angle difference. 


if (match .eq. 1) then 

if (xpassno .ne. ypassno) then 

write {*,*) *N0 MATCH BETWEEN PASS NUMBERS' , xpassno, ypassno 
endif 
endif 

if (xnobs .ne. ynobs ) then 

write (*,*) 'NO MATCH BETWEEN NUMBER OF OBSERVATIONS' 
write (*,*) 'CORRELATION COEF MAY NOT BE CORRECT’ 
write (*,*) 1 PASSNUMBERS-' , xpassno, ypassno 
write (*,*) 'FILE 1: OBSERVATIONS xnobs 
write (*,*) 'FILE 2: OBSERVATIONS -'.ynobs 
endif 

pi-3.141592654 

twopi-6. 283185307 

POWER1-ZERO 

POWER2-ZERO 

POWER3-ZERO 

POWER4-ZERO 

XPOWER-ZERO 

TPCWER-ZERO 

DO 110 i-1 , nobs 

— — zeroent array is a flagging array used to 

set the windowing array h to equal 
(0.0, 0.0) or (1.0, 0.0). a little inspection 
of subroutine BNDPAS will help illuminate 
the principle. 

zeroent (i)-l 

SUM THE POWERS £ CROSS PRODUCTS OF THE INPUT MAPS. 

POWERl— POWER! + (X (I) *C0NJG (X (I) )) 

POWER2-POWER2+ (Y (I) *CONJG (Y (I) ) ) 

XPOWER-XPOWER+ (X (I) *CONJG (Y (I) ) ) 


c xrad is the phase angle of the x array wavenumber and 

c yrad is the phase angle of the y array wavenumber, the 

c cosine of the minimum phase difference is the correlation 


of the two wavenumbers, to find the minimum phase difference 
it is necessary to adjust xrad or yrad with integer values 
of pi. so. ...do not change the order of the if statements II 

xrad-atan (aimag (x (i ) ) / (real (x (i ) ) ) ) 
if (real (x(i) ) .It. 0.0) xrad-xrad+pi 
if (aimag (x (1) ) .It. 0.0) xrad-xrad+twopi 
yrad-atan (aimag (y (i) )/ (real (y (1) ) ) ) 
if (real (y (i) ) .It. 0.0) yrad-yrad+pi 
if (aimag (y (i) ) .It .0.0) yrad-yrad+twopi 
delrad-abs (xrad-yrad) 
ccoef-cos (del rad) 


B-70 



IF (CCOEF .GT. maxcc .or. CCOEF .LT. tnincc) THEN 
X (I) -ZERO 
Y (I) -ZERO 
zerocnt (i)-0 
END IF 
c 

C SUM THE POWERS 4 CROSS PRODUCTS FOR THE OUTPUT MAPS. 

C 

POWER3-POWER3-MX<I)*CONJG(X(I) ) ) 

POWER4 -PCWER4 + (Y(I) *CONJG (Y (I) ) ) 

TPOWER-TPOWER+ (X <I) *CONJG (Y (I> ) > 

110 CONTINUE 
C 

C CALCULATE THE C.C. FOR THE INPUT MAPS. 

C 

if (powerl .eq. zero .or. power2 .eq. zero) then 
write (*,*) 'powerl , powerl, xpassno 

write {*,*) *power2 power 2, y pass no 
ccin-9999. 9 
else 

CCIN-REAL (XPOWER/SQRT (POWER1 *POWER2 ) ) 
endif 
C 

C CALCULATE THE C.C. FOR THE OUTPUT MAPS. 

C 

if (power3 .eq. zero .or. power4 .eq. zero) then 
write (*,*) 'power3 power 3 , xpassno 
write (*,*) 'power4 -' , power4, ypassno 
ccout-9999.9 
else 

CCOUT-REAL (TPOWER/SQRT (POWER3*POWER4 ) } 
endif 
C 

C CALCULATE THE PERCENTAGE OF THE POWER RETAINED IN THE FILTERED 
C MAPS. 

C 

if (powerl .eq. zero .or. power2 .eq. zero) then 
pctprl-9999. 9 
pctpr2-9999. 9 
else 

PCTPR1- (POWER3/PCWER1 ) *100. 0 
PCTPR2- (POWER4 /PCWER2 ) *100.0 
endif 
C 

C WRITE THE C.C. FOR THE INPUT 4 OUTPUT MAPS TO FILE 6. 

C 

c WRITE (6,444) CCIN 

c WRITE (6, 555) CCOUT 

C 

C WRITE THE POWER PERCENTAGES TO FILE 6. 

C 

c WRITE (6, 666) PCTPRl , PCTPR2 

c 444 FORMAT (' ' , 1 THE CORRELATION COEFFICIENT BETWEEN THE INPUT ' 

c * , 'MAPS IS ' ,F6.3) 

c 555 FORMAT (‘ 1 , ' THE CORRELATION COEFFICIENT BETWEEN THE OUTPUT ' 
c * , 'MAPS IS ' ,F6.3) 

c 666 FORMAT (' 1 , * THE PERCENTAGE OF THE TOTAL POWER IN MAP ONE', 
c *' PASSED IS ' , F7 . 3, ' THE PERCENTAGE OF THE TOTAL POWER', 
c *' IN MAP TWO PASSED IS’ , F7 . 3, ' %' ) 

C 

c 

write (25,888) xpassno, ypassno, ccin, ccout, pctprl , pctpr 2 
888 format (2i6,4fl0.3) 

if (ccin .It. minccin) write (*,*) xpassno, ypassno, ccin, ' <min' 
if (ccin .gt. maxccin) write (*,*) xpassno, ypassno, ccin, * >max' 
c 

c the following if statement controls 

c the windowing functions for smoothing 

c the output arrays and calculates a new 

c output correlation coefficient and 

c percents of power retained in the 

c windowed arrays because 

c the data will change slightly with 

c windowing 

c 

if (cnwind .ge. 1 .and. cnwind .le. 4) then 
powerS- zero 
power 6- zero 
totpwr-zero 
do i-l,nobs 

h (i) - (1. 0,0.0) 

if (zerocnt (i) .eq. 0) h(i) - (0.0, 0.0) 
enddo 

call fftld <nobs,l) 
call window (nobs, cxlag, cnwind) 
call fftld (nobs,-l) 
do i-l,nobs 

x(i) - x(i)*h(i) 
y(i) - y(i)*h(i) 

power 5 -power 5+ (x (i) *conjg(x (i) ) ) 
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power 6 -power 6+ (y (i) *con jg (y (i) ) ) 
totpwr-totpwr+ (x (i) *con jg (y (i) ) ) 
ervddo 

if (powerS .eq. zero .or. power6 .eq. zero) then 
write (*,*) 'powerS , powerS, xpassno 
write (*,*) 'powerS -', powerS, ypassno 
ccwinout-9999. 9 
go to 340 
endlf 

if (powerl .eq. zero .or. power2 .eq. zero) then 
pctpr3-9999. 9 
pctpr4-9999. 9 
go to 340 
endif 

ccwinout-real (totpwr/sqrt (power5*power6) ) 
pctpr3-(power5/powerl) *100.0 
pctpr4- (power6/power2) *100.0 
340 continue 

write (25, 888) xpassno, ypassno, coin, ccwinout,pctpr3,pctpr4 
c 868 format (2i6,4fl0.3) 

endif 
c 

return 

end 

c 

c 

c 

subroutine inverseft (num, mean, pas sno) 

integer num, xnobs,y nobs, xy nobs, row, col, passno 

real xdata (4096) , ydata (4096) , mean 

complex xcdata (4096) ,ycdata (4096) 

common /rowcol/ xnobs,ynobs 

common /reals/ xdata, ydata 

common /comps/ xcdata, ycdata 

common /fftifft/ nobs, prcnt, imean, fold 

COMMON H (4096) 

DIMENSION X (2, 4096) , holdme (4096) 

COMPLEX H 

EQUIVALENCE (X (1, 1) , H (1) ) 
c 

if (num .eq. 1) then 
xynobs-xnobs 
do i-1, nobs 

h < 1 ) - xcdata(i) 
enddo 

elseif (num .eq. 2) then 
xynobs-ynobs 
do i-1, nobs 

h (i) - ycdata (1) 
enddo 
endif 


subroutine description 

REQUIRED SUBROUTINES : 

FFT1D, FORK 

DIMENSIONING REQUIREMENTS : 

X (2, N) WHERE N IS THE NUMBER OF COLUMNS AND ROWS OF THE 

H (N) OUTPUT TRANSFORMED MATRIX. N MUST BE AN INTEGRAL 

POWER OF TWO (2,4,8,256...). 

NOTE : DIMENSIONS IN EVERY SUBROUTINE MUST BE 
SET EQUAL TO DIMENSIONS IN MAIN PROGRAM. 

AUTHOR : JEFF LUCIUS 

DEPARTMENT OF GEOLOGY AND MINERALOGY 
OHIO STATE UNIVERSITY, DECEMBER 1984. 

revised: 8 AUG 90 
updated: 2 feb 91 

added do loops that find the data portion of the 
zero centered inverse transformed data, a look at 
subroutine datwnd will help figure this out. 


INVERSE TRANSFORM DATA TO THE SPACE DOMAIN 

CALL FFT1D (nobs,+l) 

nxhalf- (nobs-xynobs) /2 
do i-nxhalf+1 , nxhalf +xynobs 
holckne (i-nxhalf ) -x (1, i) 
enddo 

total-0.0 
DO 1-1, xynobs 

x (1, i) -holckne (i) 
total-total+x (1,1) 
enddo 

xmean-total/float (xynobs) 
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IF (IMEAN .EQ. 1) THEN 
do i-l,xynobs 

x(l,i)-x (l,i)+mean 
enddo 
ENDIF 
C 

XMIN- 1.0E20 
XMAX— I.0E20 
if (num .eq. 1> then 
do i-l,xynobs 

xdata (i) - x (1, i) 
enddo 

elseif (num .eq. 2} then 
do i-l,xynobs 

ydata (i) - x (1,1) 
enddo 
endif 

DO I-l,xynobs 

XMIN -AMI N1 (XMIN,X (1,1)) 

XMAX-AMAX1 (XMAX, X (1, I) ) 

IF (XMAX.EQ.X (1,1) ) IMAX-I 
IF (XMIN.EQ.X (1,1) ) IMIN-I 
enddo 

c WRITE (25, 1020) XMAX, iMAX, XMIN, iMIN, xmean, pas sno 

write (25,9980) passno, xmean, xmax, imax, xmin, imin 
9980 format (15, 2x, fl3. 5, 2x, fl3 . 5, 2x, 14 , f 13. 5, 2x, i4) 

C 

1020 FORMAT ( 'MAXIMUM OF IFFT - ',E15.7, * AT (',13, •)'/, 

> 'MINIMUM- ' , E15 . 7, 1 AT (',13,')'/, 

> 'MEAN AFTER IFFT - «,el5.7,‘ FOR PASS' , 16, /) 
C 

return 

END 
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program combine 

integer xrow, xcol, zero, eight , xpassno, ypassno, ycol, 

> x3row,x3col,x3pass,y3row,y3col, y3pass, yrow, 

> strcnt, syrow, sy3row, sycol, sy3col, nobs, noc, 

> sypassno, sy3pass, dndk, tcount, paircnt,minobs, 

> paircntl, choice, totobs, prime, global, cr os sent, 

> passrem, nowant (4000) ,nocnt, type 

real xmean, ymean, x3data (400, 3) , y3data (400, 3) , y3mean, 

> xldata (400) , yldata (400) ,xadata (400, 4) , ybdata (400, 4 ) , 

> x3mean, sy3mean, symean,x (400) , y (400) , 

> saveyl (400) , savey 3 (400, 3) , xamean, 

> yfcnean,avgdata (400, 4) 
character* 80 filename 

common /trunstat/ xadata (400, 4) , ybdata (400, 4 ) 

common x3data (400,3), xldata (400) ,y3data (400, 3) , yldata (400) 

common /aver/ avgdata (400, 4) 

common /tplot/ x (400) ,y (400) 

common /nope/ nowant (4000) , noent 


c 

c — - program description 

c 

c combine is very similar to movetrunc in that both 

c programs truncate adjacent passes to the same over- 

c lapping segments, both programs also provide 

c statistics and track output files, the major 

c difference is that movetrunc has only one file 

c as input whereas combine has two files as input, 

c combine can output one file of two passes averaged 

c together to make the one file or it can output 

c two similar length passes that can be further 

c processed by fourier methods, movetrunc and combine 

c could be cluged together to make one program 

c so why don’t you go ahead and jam them together?? 

c good luck! ! 

c 

c program date: 16 apr 91 

c 


write <*,*) ’1 TO HAVE ONE OUTPUT FILE* 

write (*,*) ’2 TO HAVE TWO OUTPUT FILES' 

read (*,*) ifilenum 
if (ifilenum .eq. 2) then 
prime-1 
goto 3 
endif 

write <*,*) ’1 TO AVERAGE A-east AND A-west' 

write (*,*) *2 TO AVERAGE A-east AND B-west (choose 2)* 

read (*,*) prime 

3 write (*,*) *0 IF THE DATA SET IS GLOBAL OR POLAR' 

write (*,*) *1 IF THE DATA SET DOES NOT INCLUDE ALL LONGITUDES' 
read (*,*) global 
c 

If (prime .eq. 1) then 

write (*,*) 'NOTE: FILE Y WILL HAVE THE FIRST PASS MOVED' 
write <*,*) 'TO THE BOTTOM OF THE FILE' 
write (*,*) 1 * 
if (global .eq. 1) then 

write (*,*) 'AND THE FIRST PASS WILL NOT BE INCLUDED IN' 
write (*,*) 'THE PROCESSING. FILE X WILL HAVE THE LAST' 
write (*,*) 'PASS REMOVED AND THIS PASS WILL NOT BE INCLUDED* 
write (*,*) 'IN THE PROCESSING* 
endif 
endif 
c 

write (*,*) 'INPUT FILE X OF LAT-LONG-RAD DATA' 
read (*,9990) filename 
9990 format (a0O) 

open (10, file-filename, status- ' old' , form- 1 unformatted 1 ) 
write (*,*) ’INPUT FILE X OF MAGNETIC VARIABLES' 
read (*,9990) filename 

open (11, file-filename, status- ' old' , form-' unformatted' ) 
write (*,*) ’INPUT FILE Y OF LAT-LONG-RAD DATA' 
read (*,9990) filename 

open (12, file-filename, status- ' old* , form-’ unformatted' ) 
write (*,*) 'INPUT FILE Y OF MAGNETIC VARIABLES' 
read (*,9990) filename 

open (13, file-filename, status- ' old' , form-' unformatted' ) 
c 

if (ifilenum .eq. 1) then 

write (*,*) 'OUTPUT FILE OF TRUNCATED LAT-LONG-RAD-ANOM DATA' 

write (*,*) 'AND NO HEADERS TO BE WRITTEN ' 

read (*,9990) filename 

open (20, file-filename, form-' formatted' ) 

write (*,*) 'OUTPUT FILE OF LAT-LON TO BE RUN IN TPLOT' 

read (*,9990) filename 

open (21, file-filename, form- 'unformatted' ) 
c 

elseif (ifilenum .eq. 2) then 

write (*,*) 'OUTPUT FILE X OF LAT-LON -RAD’ 

read (*,9990) filename 

open (30, file-filename, form- ' unformatted' ) 
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write (*,*) 'OUTPUT FILE X OF VARIABLE* 
read (*,9990) filename 

open {31, file-filename, form-' unformatted' ) 
write {*,*) 'OUTPUT FILE Y OF LAT-LON-RAD ' 
read (*, 9990) filename 

open (32, file-filename, form-' unformatted' ) 
write {*,*) 'OUTPUT FILE Y OF VARIABLE' 
read (*,9990) filename 

open (33, file- filename, form-' unformatted* ) 
endif 

write (*,*) 'OUTPUT FILE OF STATISTICS' 
read (*,9990) filename 

open (25, f ile-file name, form-' formatted* ) 

write (*,*) '0 IF THESE ARE DUSK DATA SETS' 

write (*,*) *1 IF THESE ARE DAWN DATA SETS* 

read (*,*) dnd)c 
if (ifilenum .eq. 1) then 

write {*,*) *0 DO NOT REMOVE THE MEAN FROM THE AVERAGED DATASET* 
write {*,*) *1 REMOVE THE MEAN* 
read (*,*) choice 
endif 

write (*,*) *0 IF ALL PASSES ARE WANTED' 

write (*,*) *1 TO REMOVE THE PASSES THAT ARE NOT WANTED* 

read {*,*) nocnt 

if (nocnt .eq. 1) then 

write (*,*) 'INPUT FILE OF PASSES NOT WANTED* 
read (*,9990) filename 

open (14, file-filename, form-' formatted* , status-* old' ) 
do 5 i-1,4000 

read (14,*, end-6) nowant (I) 

5 continue 

6 continue 
nocnt-i-1 

endif 

if (prime .eq. 1) then 

write (*,*) *1 FOR A LATITUDE GAP FINDER* 
write (*,*) *2 FOR A MINIMUM OBSERVATION GAP FINDER* 
read (*,*) type 
endif 

write (*,*) 'AND FINALLY! MINIMUM NUMBER OBSERVATIONS PER PASS' 
read (*,*) mi nobs 

if (prime .eq. 1) then 

write (*,*)' * 

write (*,*)' running through dataset to find passes that'. 


> ' do not overlap' 

c findgap locates adjacent 

c passes that do not overlap 


call findgap (global, dndk, mi nobs, type) 
write (*,*) 'done with run through* 

write (*,*)' 

endif 


c 


c 


c 

10 


15 


25 

30 


35 


45 

c 

c — 


YVAR ', 
YSLOPE' , 

> * XINTCPT YINTCPT* 

paircnt-0 

paircntl-0 

tcount-0 

strcnt-0 

totobs-0 

noc-0 

crosscnt-0 

passrem-0 

continue 

read (10, end-999) x3row,x3col, zero, x3mean,x3pass, eight 
do 15 i-l,x3row 

read (10) (x3data (i, ii) , ii-1, x3col) 
continue 

read (11) xrow, xcol, zero, xmean, xpassno, eight 
do 25 i-l,xrow 

read (11) xldata(i) 
continue 
continue 

read (12, end-150) y3row, y3col, zero, y3mean, y3pass, eight 
do 35 i-l,y3row 

read (12) (y3data (i, ii) , ii-1, y3col) 
continue 

read (13) y row, ycol, zero, ymean, ypassno, eight 
do 45 i-l,yrow 

read (13) yldata(i) 
continue 


write (25,*) 

> 

write (25,*) 


' XPASS YPASS CCD 
' COVARXY XSTDEV 


CCY 

YSTDEV 

YMEAN 


XSLOPE 


strcnt-strcnt+1 


~ this if statement offsets the passes 
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c and saves the offset for the end 

if (strcnt .eq. 1 .and. prime .eq. 1) then 
do 50 i-l,y3row 

do 55 ii-l,y3col 

savey3 (i, ii) -y3data <i, ii) 

55 continue 

saveyl (I)-yldata {i ) 

50 continue 

sy3row-y3row 
syrow-yrow 
sy3col-y3col 
sycol-ycol 
sy3mean-y3mean 
symean-ymean 
sy3pass-y3pass 
sypassno-ypassno 
go to 30 
endif 
c 

go to 190 
c 

150 continue 

if (global .eq. 1) go to 999 
do 160 i-l,sy3row 

do 165 ii-1, sy3col 

y3data(i,ii)-savey3 (1, ii) 

165 continue 

yldata (i)-saveyl (i) 

160 continue 

y3row-sy3row 

yrow-syrow 

y3col-sy3col 

ycol-sycol 

y3mean-sy3mean 

ymean-symean 

y3pass-sy3pass 

ypassno-sypassno 

c 

190 continue 
c 

if (xrow . ne „x3row .or. xpassno.ne . x3pass .or. 

> yrow. ne ,y3row .or. ypassno.ne.y3pass) then 

write (*,*> 'WACKO, TRA-LA-LA, JOLLY-GOOD, NO MATCH BETWEEN ' 
write (*,*> ‘ROWS OR PASSNOS X- ' , xrow, x3row, xpassno, x3pass 
write (*,*)' Y- ', yrow, y3row, ypassno, y3pass 

go to 999 

elseif (xrow .It. minobs .or. yrow .It. minobs) then 

write (*,*) 'FILE X PASS ', xpassno, ' REMOVED: OBSERVATIONS- xrow 
write (*,*) 'FILE Y PASS ' , ypassno, ' REMOVED: OBSERVATIONS- ', yrow 
passrem-passrem+l 
go to 10 
endif 

do 195 i-l,nocnt 

if (nowant (i >. eq. xpassno .or. nowant (i ). eq. ypassno) then 
write (*,*) 'FILE X PASS' , xpassno, ' REMOVED NOT WANTED' 
write (*,*) 'FILE Y PASS' , ypassno, ' REMOVED NOT WANTED' 
pa s s r em-pa ss r em+l 
go to 10 
endif 
195 continue 
c 

call truncate (xrow, yrow, dndX, nobs, pa i rent 1, mi nobs) 
c 

call statistics (nobs, xpassno, ypassno, xamean, ybenean) 
c 

If (ifilenum .eq. 1) call average (nobs, choice, prime, crosscnt) 
c 

if (ifilenum .eq. 2) then 

if (xpassno .ne. ypassno) then 

write (*,*) xpassno, ypassno, ' no match pass numbers' 
stop 444 
endif 
ithree-3 
ione-1 
xxavg-0. 0 
ieight-B808 
i zero-0 

write (30) nobs, lthree, zero, xxavg, xpassno, ieight 
write (31) nobs, lone, zero, xxavg, xpassno, ieight 
write {32 ) nobs, ithree, zero, xxavg, ypassno, ieight 
write (33) nobs, lone, zero, xxavg, ypassno, ieight 
do j-l,nobs 

if (xadata ( j, 3) .gt. 180.0) xadata ( j, 3)-xadata ( j, 3)-360.0 
write (30) xadata (j, 1) , (xadata ( j, i) , i-3, 4) 
write (31) xadata(j,2) 

if (ybdata(j,3) .gt. 180.0) ybdata ( j, 3)-ybdata ( j, 3J-360.0 
write (32) ybdata (j, 1) , (ybdata ( j, i }, i-3, 4) 
write (33) ybdata(j,2) 
enddo 
go to 300 
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endif 


c write out the truncated lengths passes 

c 

if (prime .eq. 1) then 
do 200 j-1, nobs 

if (xadata(j,3) .gt. 180.0) xadata ( j, 3) -xadata (j, 3) -360.0 
write (20,*) xadata( j,l), (xadata(j,i) , i-3, 4) ,avgdata ( j, 4) 
200 continue 

do 205 j-l,nobs-l 

if (xadata(j, 3) .It. xadata ( j+1, 3) ) then 
crosscnt-crosscnt+1 
go to 207 
endif 

205 continue 

207 continue 

elseif (prime .eq. 2) then 
do 220 j-1, nobs 

if (avgdata ( j, 2) .gt.180.0) avgdata* j, 2) -avgdata (j, 2) -360.0 
write (20,*) (avgdata ( j, k) , k-1, 4) 

220 continue 

endif 


write out the trace of the pass for plotting 

c in tplot 

call track (nobs, noc, prime) 

WRITE (21) NOC,NObs, (X(J),Y(J), J-l,NObs) 

C 

300 continue 

if (paircntl .gt. 0) tcount-tcount+1 

paircnt-paircnt+paircntl 

totobs-totobs+nobs 


go to 10 
999 continue 


write 

<*,* 

write 

(*,* 

write 

( \ * 

write 

<*,* 

write 

<*,* 

write 

(*,* 

close 

(10) 

close 

(11) 

close 

(12) 

close 

(13) 

close 

(20) 

close 

(21) 

close 

(25) 

close 

(30) 

close 

(31) 

close 

(32) 

close 

stop 

end 

(33) 


'corrected' ,paircnt, ’ pairs of latitudes in' 
tcount, ' passes to beginning lengths' 

'total passes read - ',strcnt 

'removed 1 , pass rem, * passes from the file' 

'total observations in the written dataset -*,totobs 
'study area includes crosscnt, ' pairs of', 

' longitudes that cross -180.0 100.0' 


c 


c 

c 

subroutine truncate (xrow,yrow, dndk,minrow, stocount,minobs) 
Integer xrow,yrow, stocount , rowii, rowinc,minrow, 

> dndk, minobs 

real xdata (400, 4 ) , ydata (400, 4 ) , 

> x3data (400, 3) ,xldata (400) , y3data (400, 3) , yldata (400) , 

> adata, bdata, diffab, abss, xadata (400, 4) , ybdata (400, 4 ) 
common /trunstat/ xadata (400, 4) , ybdata (400, 4) 

common x3data (4 00, 3) , xldata (400) , y3data (400, 3) , yldata (400) 


subroutine description 

c truncate locates the overlapping segment between two 

c adjacent passes and stores that segment in the 

c appropriate arrays 

c 

do 70 j-1 , xrow 

xdata (j, l)-x3data< j , 1 ) 
xdata (j, 2) -xldata (j) 
xdata ( j , 3) -x3data <5,2) 
xdata < j , 4 ) -x3data ( j , 3 ) 

70 continue 

do 75 j-1 , yrow 

ydata ( j, 1 ) -y3data ( j , 1 ) 
ydata ( j, 2 ) -yldata (j) 
ydata (j, 3) -y3data ( j, 2) 
ydata ( j, 4) -y3data{ j, 3) 

75 continue 
c 

00 continue 
stocount-0 

jj-l 

rowii-xrow 
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rowinc-yrow 

c loops from 90 to 200 increment through the 

c two input passes and truncate the lengths 

c to the same length 

90 continue 


adata-xdata ( j j, 1 ) 
bdata-ydata ( j j, 1 } 
di f fab-adata-bdata 
abss-abs {dif fab} 

if (rowii .eq. 0 .or. rowinc .eq. 0) then 

write (*,*) ‘xrows <ii) -', rowii,' yrows (inc) rowinc 
write (*,*) 'xrow -',xrow, 1 yrow -',yrow 
stop 
endif 

mlnrow^nin (rowii, rowinc) 

c if pass a (ii) matches pass b (inc) at 

c beginning length then write to xdata and 

c ydata and race to main program 

if (abss .It. 0.33) then 
do 110 11-1, minrow 
do 110 kk-1,4 

xadata (11, kk) -xdata (11, kk) 
ybdata (11, kk) -ydata (11, kk) 


110 continue 
return 
endif 

c if pass a no matcha the b data then find new 

c a or b depending on whether or not ascending 

c or descending order of independent variable 

if (abss .ge. 0.33) then 
stocount-stocount+1 

c if this is a dusk pass then will count from 

c -90.0 lat degrees toward the equator 


if (dndk .eq. 0) then 

if (xdata (j 1 ) .gt. ydata ( j j, 1 ) ) then 
rowinc-rowinc-1 
do 130 mm-1, rowinc 
do 130 kk-1,4 

ydata (mm, kk) -ydata (mm+1 , kk) 

130 continue 

elseif (xdata(jj,l) .It. ydata(jj,l}) then 


rowii-rowii-1 
do 150 nn«l, rowii 
do 150 kk-1,4 

xdata (nn, kk) -xdata (nn+1, kk) 

150 continue 

endif 

c if this is a dawn pass then will count from 

c the equator toward the south pole 

c that is decreasing independent variable 


elseif (dndk .eq. 1) then 

if (xdata(jj,l) .It. ydata(jj,l)) then 
rowinc-rowinc-1 
do 160 rrm-1, rowinc 
do 160 kk-1,4 

ydata (mm, kk) -ydata (mm+1 , kk) 

160 continue 

elseif (xdata(jj,l) .gt. ydata ( j j, 1 ) ) then 
rowii-rowii-1 
do 170 nn-1, rowii 
do 170 kk-1,4 

xdata (nn, kk) -xdata (nn+1, kk) 

170 continue 

endif 
endif 
endif 
c 

go to 90 
c 

end 
c 
c 
c 
c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


subroutine statistics (minrow,xpassno, ypassno,xamean,ybmean) 
integer minrow, nobs, xpassno, ypassno 
real xadata (400, 4) , ybdata (400, 4 ) , nobss 
common /trunstat/ xadata (400, 4) , ybdata (400, 4 ) 

from 200 to write statement of variables is 

the statistical calculations using two 
references : 

1) Davis, Statistics and Data Analysis in 
Geology, 2nd ed. , 1986 pp. 41 

2) Young, Statistical Treatment of Experi- 
mental Data, 1962, McGraw Hill, 115-132 

loops that sum x, x**2, y, y**2 and xy 

and calculate new truncate means 

nobs -minrow 
nobss -float (nobs) 
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xsum-0.0 

xsumsqr-0.0 

ysum-0.0 

ysumsqr-0.0 

sumxy-0.0 

do 240 j-1, nobs 


xsum-xsum+xadata ( j, 2) 
xsumsqr-xsumsqr+ (xadata ( j , 2 ) ) * * 2 
y sum-ysum+ybdata ( j , 2 ) 
ysumsqr-ysumsqr+ (ybdata{ j, 2) )**2 
sumxy-sumxy+ (xadata (j, 2) *ybdata ( j, 2) ) 

240 continue 

c write {*,*) xsum,ysum,xsumsqr, ysumsqr, sumxy 

c find corrected sum of products, covariance 

c and corrected sum of squares (x) (y) 

c 


xame a n-xs um/ nobs s 
ybmean-ysum/ nobss 
sumprod-sumxy- ( (xsum*ysum) /nobss) 
covarxy-sumprod/ (nobss-1.0) 
xcsumsqr-xsumsqr- ( (xsum**2) /nobss) 
ycsumsqr-ysumsqr- ( (ysum**2) /nobss) 
c 

c find variance, standard deviation for x and y 

c 

xvar-xcsumsqr/ (nobss-1 .0) 
yvar-ycsumsqr/ (nobss-1 .0) 
xstdev-sqrt (xvar) 
ystdev-sqrt (yvar) 

c — find correlation coefficient by Davis method 

corrDxy-covarxy/ (xstdev*ystdev) 

c find slopes, intercepts and correlation 

c coefficient by Young method 

xslope- ( (nobss* sumxy) -(xsum*y sum) ) / ( (nobss*xsumsqr) -xsum**2) 
yslope- ( (nobss*sumxy ) - (xsum*ysum) ) / ( (nobss*ysumsqr) -ysum**2) 
xintcpt- ( (ysum*xsumsqr) - (sumxy*xsum) ) / ( (nobss*xsumsqr)-xsum**2) 
yintcpt- ( (xsum*ysumsqr) - (sumxy*ysum) ) / ( (nobss*ysumsqr)-ysum**2) 
corrYxy-sqrt (xslope*y slope) 
c 

c write out this mess for individual pass and 

c overlapping lengths of passes 

c 

c write (25, 9992 ) xpassno, ypassno, xvar, yvar, xstdev, ystdev, 
c > xamean, ybrnean 

9992 format (' FOR OVERLAPPING LENGTHS X-',i5,* Y-*,i5,/, 

> 'X VARIANCE-’, f 9. 3, ’ Y VARIANCE- f 9. 3, ' X STDEV- 1 , 

> f 9. 3, * Y STDEV-' ,f 9.3, ' XMEAN- 1 , f 9. 3, ' YMEAN-' , f 9 . 3) 

c write (25,9993) covarxy, corrDxy 

9993 format ('COVARIANCE XY-’,f9.3, ' Davis CORRELATION COEF-',f9.3) 

c write (25,9994) xslope, xintcpt, yslope, yintcpt, corrYxy 

9994 format ('X SLOPE-' , f 9.3, * X INTERCEPT- \ f 9. 3, ' Y SLOPE-', 

> f 9 . 3, ' Y INTERCEPT-' ,f 9.3, • Young CORRELATION COEF- ' , 

> f 9. 3, /) 
c 

write (25,9995) xpassno, ypassno, corrDxy, corrYxy, xvar, yvar, 

> covarxy, xstdev, ystdev 

9995 format (2i5, 7 (f 10. 4) ) 

write (25,9996) xamean, ybmean, xslope, yslope, xintcpt, yintcpt 

9996 format (lOx, 6 (f 10. 4) ) 
return 

end 

c 

c 

c 

c 

subroutine average (nobs, choice, prime, crosscnt) 
real xadata (400, 4 ) ,ybdata (400, 4 ) , avgdatmean, avgdatsum, 

> avgdata (400, 4 ) , nobss 
integer nobs, choice, prime, crosscnt 

ccmmon /trunstat/ xadata (400, 4) ,ybdata (400, 4) 


common /aver/ avgdata (400, 4 ) 
c 

c subroutine description 

c average calculates the average magnetic value of the 

c input passes, it will also find the average position 

c of the input passes if so directed. 


c 

avgdatsum-0. 0 
nobss -real (nobs) 
c 

if (prime ,eq. 2) then 
do 100 i-l,nobs 

avgdata (i,l>-( (xadata (i, 1 ) +ybdata (i, 1 ) )/2.0) 
avgdata (i, 2) - ( (xadata (i, 3) +ybdata (i, 3} ) /2.0) 
addxy - abs (xadata (i, 3) ) + abs (ybdata (i, 3) ) 
if (addxy .gt. 270.0) then 
crosscnt-crosscnt+1 

if (ybdata (i, 3) .gt.0.0 .and. xadata (i, 3) .It .0.0) then 
xadata(i,3) - xadata(i,3) + 360.0 
elseif (ybdata (i, 3) . It . 0. 0 .and. xadata (i, 3) . gt. 0.0) then 
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> 


100 


150 

c 


200 


250 


c 

c 

c 

c 


c 

c- 

c 

c 

c 

c 

c 

c 


200 


300 

C 

c 

c 

c 


c- 

c 

c 

c 

c 

c 

c 


ybdata (i, 3) - ybdata (i, 3) + 360.0 
endif 

avgdata (i, 2) - ( (xadata (i, 3) +ybdata (i, 3) ) /2.0) 
if (avgdata (i, 2) .gt. 180.0) 

avgdata (i, 2) -avgdata (i, 2) -360.0 

endif 

avgdata (i, 3) - ( (xadata (i, 4 } +ybdata (i, 4) ) /2.0) 
avgdata (i, 4)-( (xadata (i, 2) +ybdata (i, 2) ) /2.0) 
avgda t sum- a vgdatsum+ avgdata (i, 4 ) 
continue 

avgdatmean-avgdatsum/nobss 
if (choice .eq. 1) then 
do 150 i-l,nobs 

avgdata (i, 4 ) -avgdata (i , 4 ) -avgdatmean 
continue 
endif 

elseif (prime .eq. 1) then 
do 200 i-l,nobs 

avgdata (i, 4) - ( (xadata (i, 2) +ybdata (i, 2) ) /2.0) 
avgdatsum-avgdatsum+avgdata (i, 4 ) 
continue 

avgdatmean-avgdatsum/nobss 
if (choice .eq. 1) then 
do 250 i-l,nobs 

avgdata (i, 4) -avgdata (i, 4) -avgdatmean 
continue 
endif 
endif 

return 

end 


subroutine track (nop, noc, prime) 
integer nop, noc, prime 

real radfac, avgdata (400, 4 ) , x (400) , y (400) , xadata (400,4), 

> ybdata (400, 4 ) 
common /aver/ avgdata (400, 4 ) 
common /tplot/ x (400) , y (400) 
common /trunstat/ xadata (400, 4 }, ybdata (400, 4 ) 

subroutine description 

track finds the lat and long coordinates of the observations 
along an orbit, these coordinates can be plotted as the 
trace of the pass along the earth. 

NOTE: lat and long are changed to radians for the plotting 
package that i use. 

RADFAC-0. 017453293 
noc-noc+1 

if (prime .eq. 2} then 
DO 200 J-l , NOP 

x ( j) -90 . 0-avgdata ( j, 1 ) 

y (j) -avgdata (j, 2) 

if (y(j) .lt.0.) y ( j) -y ( j) + 360. 

X (J) -X ( J) * RADFAC 
Y (J)-Y(J)* RADFAC 
CONTINUE 

elseif (prime .eq. 1) then 
do 300 j-l, nop 

x ( j ) - 90.0 - xadata ( j, 1 ) 
y(j) - xadata ( j, 3) 

if (y ( j) .It. 0.0) y ( j) - y ( j) + 360.0 
x ( j) - x ( j) * radfac 
y ( j) - y(j) * radfac 
continue 
endif 

return 

end 


subroutine findgap (global, dndk,minobs, type) 
integer zero, eight, strtotpass, x3row, x3col, x3pass, 

> y3row, y3col, y3pass, cnt, type, strmincnt, 

> dndk, nowant (4000) , nocnt,mincnt, 

> mi nobs, totpass, global, 

> nopass, st rnocnt,al lent, strallcnt 

real y3data (400, 3) ,y3mean, abss,allxdat (4000, 4 ) , 

> allydat (4000, 4) , x3mean, x3data (400, 3) , stryone (4 ) 
common /nope/ nowant (4000) , noent 

subroutine description 

findgap locates the overlapping segment in each of the 
two adjacent passes, this is done by looking at the 
first and last latitudes in each pass and comparing 
the values, if there are two passes that do not have 
overlapping segments, then one of the two passes 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 


10 


15 


30 

31 
35 


c 

50 

c 

52 

55 

57 

c 

c 

c 

70 

c 

100 


is removed. 

NOTE: the difference between a latitude gap finder and 
a minimum observation gap finder is: a latitude 

finder allows extremely short passes to be worked 
with in the processing whereas a minimum observation 
gap finder removes all short passes, the trade off 
occurs because a minimum observation finder actually 
allows a higher number of observations to be worked 
with in collocation, therefore a minobs gap finder 
is usually best, experiment to see what u like. 

totpass-0 

allcnt-0 

strnocnt-nocnt 

continue 

read (10, end-30) x3row, x3col, zero, x3mean / x3pass. eight 
do 15 l-l,x3row 

read (10) (x3data (i, ii ) , ii-1 , x3col ) 
continue 

totpass- totpass +1 
if (x3row .It. minobs) then 
nowant (nocnt+1) -x3pass 
nocnt-nocnt+1 
endif 

allcnt-allcnt+1 

allxdat (allcnt, 1) -real (x3pass) 
allxdat (allcnt, 2) -real (x3row) 
allxdat (allcnt, 3) -x3data (1, 1) 
allxdat (allcnt, 4 )-x3data (x3row, 1) 
go to 10 

continue 

strtotpass-totpass 

strallcnt-allcnt 

totpass-0 

allcnt-0 

read (12, end-50) y3row, y3col, zero, y3mean, y3pass, eight 
do 35 i-l,y3row 

read (12) (y3data (i, ii ) , ii-l,y3col ) 
continue 

totpass-totpass+1 
if (y3row .It. minobs) then 
nowant (nocnt+1) -y3pass 
nocnt-nocnt+1 
endif 

allcnt-allcnt+1 

allydat (allcnt , 1 ) -real <y3pass) 
allydat (allcnt , 2 ) -real (y3row) 
allydat (allcnt , 3 ) -y3data (1, 1 ) 
allydat (allcnt, 4 ) -y3data (y3row, 1) 
go to 31 

continue 

if (totpass. ne. strtotpass .or. allcnt . ne. strallcnt) then 
write <*,*) 'FILES DO NOT HAVE THE SAME NUMBER OF PASSES* 
write (*,*) ‘FILE X PASS COUNT- ', strtotpass, strallcnt 
write <*,*) 'FILE Y PASS COUNT- totpass, allcnt 
stop 
endif 

do 52 ii-1, 4 

stryone (11) -allydat (1,11) 
continue 

do 55 i-l,allcnt-l 
do 55 ii-1, 4 

allydat (1,11) -allydat (1+1,11) 
continue 
do 57 ii-1, 4 

allydat (allcnt, ii) -stryone (ii) 
continue 

if (global .eq. 1) allcnt -allcnt-1 
if (type .eq. 2) go to 400 

work a latitude gap finder 

continue 

cnt-1 

continue 

If (allxdat (cnt,l) .ne. allydat (cnt, 1 ) ) then 

write {+,+) * PASSES DO NOT MATCH FOR A-east A-west* 
write (*,+) 'REVERSE THE ORDER OF INPUT FILES AND RERUN* 
stop 
endif 

if (nocnt .eq. 0) go to 140 
do 110 i-1, nocnt 

if (int (allxdat (cnt, 1) ) .eq. nowant (i)) then 
If (cnt+1 .gt. allcnt) go to 190 
do 105 jj-cnt, allcnt-1 
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do 105 j-1,4 

allxdat (jj, j)-allxdat ( jj+1, j) 
allydat ( j j, j) -allydat ( j j+1, j) 

105 continue 

allcnt-allcnt-1 
endif 
110 continue 
140 continue 

abss-abs (allxdat (cnt, 3) -allydat (cnt, 3) ) 
if (abss .it. 0.33} go to 190 
if (abss .ge. 0.33) then 

nopass-int (allxdat (cnt, 1 } ) 

c if this is a dusk pass then will count from 

c -90.0 lat degrees toward the equator 

if (dndk. .eq. 0} then 

if (allxdat (cnt, 3) ,gt. allydat (cnt, 3) ) then 
if (allxdat (cnt, 3) .gt. allydat (cnt, 4) ) then 
nocnt-nocnt+1 
nowant (nocnt ) -nopass 
endif 

elseif (allxdat (cnt, 3) .It. allydat (cnt, 3) ) then 
if (allxdat (cnt, 4 } .It. allydat (cnt, 3) ) then 
nocnt-nocnt+1 
nowant (nocnt } -nopass 
endif 
endif 


c if this is a dawn pass then will count from 

c the equator toward the south pole 

c that is decreasing independent variable 


elseif (dndk .eq. 1) then 

if (allxdat (cnt, 3) .It. allydat (cnt, 3) } then 
if (allxdat (cnt, 3) .It. allydat (cnt, 4 ) } then 
nocnt-nocnt+1 
nowant (nocnt) -nopass 
endif 

elseif (allxdat (cnt, 3) .gt. allydat (cnt, 3) ) then 
if (allxdat (cnt, 4 ) ,gt. allydat (cnt, 3) ) then 
nocnt-nocnt+1 
nowant (nocnt) -nopass 
endif 
endif 
endif 
endif 

190 continue 
cnt-cnt+1 

if (cnt .gt. allcnt) go to 200 
go to 100 

200 continue 

if (nocnt .eq. strnocnt) go to 999 
if (strnocnt .It. nocnt) then 
strnocnt-nocnt 
go to 70 
endif 


c work a minimum observations gap finder 

400 continue 
mincnt-0 
st rmi ncn t-mi ncnt 
c 

470 continue 
cnt-1 
c 

500 continue 

if (allxdat (cnt, 1) .ne. allydat (cnt , 1 } ) then 

write (*,*) 'PASSES DO NOT MATCH FOR A-east A-west' 
write (*,*) 'REVERSE THE ORDER OF INPUT FILES AND RERUN' 
stop 
endif 

if (int (allxdat (cnt, 2) ) .It. minobs .or. 

> int (allydat (cnt, 2) ) .It. minobs) then 
if (cnt+1 .gt. allcnt) go to 590 
do 505 j j-cnt,allcnt-l 
do 505 j-1,4 

allxdat ( j j, j) -allxdat ( j j + 1, j) 
allydat ( j j, j) -allydat (5 j + 1, j) 

505 continue 

allcnt-allcnt-1 
go to 500 
endif 

510 continue 
540 continue 

abss-abs (allxdat (cnt , 3) -allydat (cnt, 3) ) 
if (abss .It. 0.33} go to 590 
if (abss .ge. 0.33) then 
xrow-int (allxdat (cnt, 2) ) 
yrow-int (allydat (cnt, 2) ) 
mi nxy row-mi n (xrow, yrow) 
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mincnt2-mincnt 


c if this is a dusk, pass then will count from 

c -90.0 lat degrees toward the equator 


if {dndk .eg. 0) then 

if (allxdat (cnt, 3) .gt. allydat (cnt, 3) > then 

if (allxdat (cnt, 3) .gt. allydat (cnt, 4 ) ) mincnt*nnincnt+l 
elseif (allxdat (cnt, 3) .It. allydat (cnt, 3) ) then 

if (allxdat (cnt, 4 ) .It. allydat (cnt , 3) ) mincnt^nincnt+1 
endif 

c if this is a dawn pass then will count from 

c the equator toward the south pole 

c that is decreasing independent variable 

elseif (dndk .eq. 1} then 

if (allxdat (cnt, 3) .It. allydat (cnt, 3) ) then 

if (allxdat (cnt, 3) .It. allydat (cnt, 4 ) ) mincnt^nincnt+1 
elseif (allxdat (cnt, 3) .gt. allydat (cnt, 3) > then 

if (allxdat (cnt, 4) .gt. allydat (cnt, 3) } mincnt^nincnt+1 
endif 
endif 

if (mincnt .gt. mincnt2) minobs-minxyrow+1 
endif 
c 
c 

590 continue 
cnt-cnt+1 

if (cnt .gt. allcnt) go to 600 
go to 500 
c 

600 continue 

if (mincnt .eq. strmincnt) go to 999 
if (strmincnt .It. mincnt) then 
strmincnt-mincnt 
go to 470 
endif 
c 

999 continue 

write {*,*) 'total passes read - ',totpass 
if (nocnt .gt. 0) then 

write (*,*) 'will remove the following passes from processing' 
do 1010 1-1, nocnt 

write (*,*) nowant (i),i 
1010 continue 
endif 

if (type .eq. 2) write (*,*) 'new minimum observation cutoff', 

> ' is -',minobs 

rewind (10) 
rewind (12) 
c 

return 

end 
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-12.4245 

16.2844 

0.7764 

0.1974 

e 

6 

.6345 

17.7860 

- 0.0000 

0.3800 

8 

7 

10.5919 

-23.0130 

0.0000 

0.4037 

8 

8 

-1.6744 

-9.6949 

1.7731 

0.0000 

9 

1 

18.4829 

0 

0.7492 

0 

9 

2 

6.5464 

6.8482 

0 

-0.6295 

9 

3 

-.4431 

-17.7074 

0.3060 


9 

4 

-10.9846 

4.2139 



9 

5 

-6.9316 

-22.1996 

-.8890 


9 

6 

4.2292 

9.1278 

.2806 

.6764 

9 

7 

2.7169 

16.0818 


-.8512 

9 

8 

6.0254 

-13.2103 



9 

9 

-1.3743 

-14.5602 

-2.2246 

-1.7360 

10 

1 

5.2888 

0 

-.2980 


10 

2 

10.3522 

-20.8464 


.4655 

10 

3 

1.3838 

15.5210 

.4694 


10 

4 

-12.3472 

8.7402 


.8824 

10 

5 

9.4401 

-5.3002 


. 5640 

10 

6 

-3.4208 

-6.3179 

-.0717 


10 

7 

-1.1873 

9.0043 



10 

8 

6.7100 

9.6459 



10 

9 

1.4932 

-5.9579 

-.4223 

.3562 

10 

10 

-4.9898 

1.9550 

-1.0560 

2.0960 

11 

1 

-3.4630 

0 

.8585 


11 

2 

-4.0062 

1.2249 


-.4876 

11 

3 

2.2272 

.5099 

-.4740 


11 

4 

-5.4032 

2.6612 

-.2979 

-.4653 

11 

5 

-1.9878 

5.7745 

.7246 

-.9477 

11 

6 

4.5775 

-4.2379 


-.6276 

11 

7 

3.1480 

-.4134 



11 

8 

.9039 

-1.3354 

-.6724 


11 

9 

1.9700 

3.5658 

1.2551 


11 

10 

2.8069 

-.4729 

.1466 

-.2740 

11 

11 

-.2741 

-6.1331 

-.5215 


12 

1 

2.4795 

0 



12 

2 

-1.1335 

.6132 



12 

3 

-1.6582 

1.7210 



12 

4 

2.1526 

-1.3117 



12 

5 

.0610 

-3.1316 



12 

6 

-.6072 

.7970 



12 

7 

-.3238 

-.0409 



12 

8 

1.6151 

-2.4801 



12 

9 

1.7163 

-.3808 



12 

10 

-.7606 

-1.6667 



12 

11 

2.0084 

-1.5290 



12 

12 

3.4451 

0.7629 



13 

1 

-1.7069 

0 



13 

2 

-.1409 

.2182 



13 

3 

-.2764 

.7604 



13 

4 

-.2045 

2.5462 



13 

5 

.6790 

-1.4956 



13 

6 

.6367 

.3952 



13 

7 

-.4485 

.2423 



13 

8 

-.1787 

-.2355 



13 

9 

.2656 

.0192 



13 

10 

-.4602 

-.0133 



13 

11 

0.1407 

-1.2097 



13 

12 

.5953 

.3708 
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13 

13 

-.1378 

.4564 

14 

1 

-.2049 

0 

14 

2 

-.5967 

-.4816 

14 

3 

.3725 

.3039 

14 

4 

-.8791 

1.4826 

14 

5 

-.1829 

-.2216 

14 

6 

1.1048 

-.4758 

14 

7 

-.4404 

-.2088 

14 

8 

.3847 

.7995 

14 

9 

-.4823 

.0535 

14 

10 

.1867 

.8530 

14 

11 

-.1106 

.0633 

14 

12 

.3455 

-.1350 

14 

13 

-.0851 

0.2500 

14 

14 

.3797 

-.3340 

-1 

0 

0 . 

0 . 
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APPENDIX C: MAP PROCESSING 

PROGRAMS 
collocation .f 
fourier2d.f 
avgdifres.f 
sqrmap.f 
inversion, f 

DATA FILE 
rmagcov 






program collocation 

Q ******************************************************* 

C THIS PROGRAM READS A FILE OF IRREGULARLY DISTRIBUTED 
C DATA POINTS { LATITUDE , LONGITUDE, ELEVATION, ANOMALY 
C VALUE) AND PREDICTS THE GRIDDED ANOMALIES ON A GRID OF 
C SPECIFIED DENSITY. THE ANOMALY ESTIMATE FOR EACH GRID 
C LOCATION IS OBTAINED FROM NCPP NEAREST SAMPLE POINTS 
C USING A LOCAL COVARIANCE MODEL. THE PROCEDURE KNOWN AS 
C LEAST-SQUARES COLLOCATION INVOLES THE FOLLOWING STEPS: 

C 

C 1. REMOVE THE MEAN OF THE ANOMALIES IN THE PREDICTION 
C AREA TO OBTAIN RESIDUALS CENTERED AROUND MEAN 

C 2. SEARCH FOR THE NCPP CLOSEST DATA POINTS TO THE GRID 
C LOCATION AND STORE THEM IN VECTOR (Ml) 

C 3. FORM THE COVARIANCE MATRIX (COVM) OF THE NCPP DATA 

C POINTS 

C 4. ADD THE ERROR VARIANCE OF THE DATA POINTS TO THE 

C DIAGONAL OF 'COVM' MATRIX, TO FORM THE FINAL 'COVM' 

C MATRIX 

C 5. INVERT 1 COVM 1 MATRIX AND STORE THE RESULT AGAIN IN 
C 'COVM' 

C 6. FORM THE CROSS-COVARIANCE VECTOR (T1 ) BETWEEN THE 
C GRID VALUE TO BE PREDICTED AND THE NCPP DATA POINTS 

C 7. BY LEAST SQUARES COLLOCATION, THE ANOMALY ESTIMATE 

C IS GIVEN AS: 

C 

C TP-Tl*COVM*Ml 

C 

C AND THE STANDARD ERROR OF PREDICTION IS GIVEN BY, 

C 

C SEP-DSQRT (VAR-Tl*COVM*Tl) 

C 

C VAR. . .COVARIANCE AT ZERO SEPARATION (I.E. VARIANCE) 

C 

c 

C 

C THE ABOVE EQUATIONS INVOLVE THE MATRIX OPERATIONS. 

C 

C +****★******************★★***************************** 

c 

C PRELIMINARY SOFTWARE EXPLICITLY DEVELOPED FOR GRAVITY 
C PREDICTION OVER A SPHERICAL SURFACE WAS MADE AVAILABLE 
C BY GEODETIC SCIENCE DEPARTMENT AT THE OHIO STATE 
C UNIVERSITY. IT WAS MODIFIED FOR NASA MAGNETIC SATELLITE 
C APPLICATION FOR 3-D PREDICTION AND THEREBY ALTITUDE 
C NORMALIZATION. 

C 

C MODIFICATIONS BY: HARISH K. GOYAL 

C DEPT. OF GEOL £ MIN, OSU 

C TEL. 422-1434, CAMPUS 

C MAR, 1966 

c 

C 1. LATITUDES ARE CHANGED TO CO-LATITUDES TO COMPLY 

C WITH SPHERICAL COORDINATES. 

C 2. SEPARATION DISTANCES ARE THE RADIAL VECTORS TO 

C ACCOUNT FOR THREE DIMENSIONAL VARIABILITY 

C 3. COVARIANCES ARE AUTOMATICALLY SCALED IN THE 

C PROGRAM 

c 

c further modlf lcations 11 may 90 

c these modifications are all lower case letters 

c 

c well'p just a few more modif lcations on 8 sep 90 

c these changes are: 1) removal of unnecessary arrays 

c 2) changing all arrays to real*4 and not real*8 

c 3) keeping all arrays that work with the inversion as 

c real*8. 4) removing every blasted 'nbug' statement i could 
c get my hands on!! 5) reading the data once storing everything in 

c memory -ie. not reading the data twice. 6) changing all logical 

c true and false statements to user friendly statements, 
c 7) this program could be faster by inverting only the half of 

c the symmetric covariance matrix (covm) and there probably is a 

c faster routine for searching for the closest points, 

c 

Q ******************************************************* 

C 

C INPUT PARAMETERS 

C 

C NORTH. . .NORTH LATITUDE OF DATA AREA 

C SOUTH ... SOUTH LATITUDE OF DATA AREA 

C WEST... WEST LONGITUDE OF DATA AREA 

C EAST... EAST LONGITUDE OF DATA AREA 

c note: use the following example if you want an equal- 
c area projection, say you are working at the south 

c pole from -40S to -83S and including all longitudes, 

c then instead of choosing north— 40, south— 83, 

c west— 180 and east-180 (which are appropriate for 

c non-equal area degrees) choose instead: 

c north-55, south— 55, west — 55, east-55. 55 comes 

c from the following calculation. from -40 to 
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c -83 degrees is 43 points, however, an equal area 

projection will go all the way to the pole because 
the pole will be centered at the middle of the grid 
(unlike the non-equal area degree projection where 
the pole is at the southern edge of the grid) so, 
frcm -40 to -90 is 50 points and you should add a few 
points for a rind around the edge, say 5 points. 

55-50+5. get it? now, if you are going to work with 
an equal area projection, you MUST transform the 
coordinates of the input data points from the degree 
domain to the spatial domain, program getllraspc.f does 
this transformation, also, if you want to convert a 
grid from/to equal-area to/ from non-equal degree then 
use program deg2spc.f to do the coordinate transform 
and use collocation to get the values at the new grid 
coordinates, clear as mud, eh? email me at 
alsdorf@geols.mps.ohio-state.edu 
if you need help. 

NX. .. NO. OF GRID PTS IN THE LONG. DIRECTION, MINUS ONE 

NY. . .NO. OF GRID PTS IN THE LAT. DIRECTION, MINUS ONE 
NCOV. . .NUMBER OF ENTRIES IN COVARIANCE FUNCTION 

and is determined by the program 
NCPP...N0. OF NEAREST POINTS USED FOR PREDICTION 
ELEV. . .COMMON ALTITUDE FOR GRIDDED ANOMALY DATA 

and is in kilometers from — SURFACE — of the earth 
E STD. . .STANDARD DEVIATION OF OBSERVATIONAL ERROR 
(ERROR VARIANCE-ESTD+*2) 
from read of file 10 

THI .. .LATITUDE COORDINATE 
PHI. . .LONGITUDINAL COORDINATE 

RAD... RADIUS VECTOR FROM — CENTER — OF THE EARTH 
ANO. . .ANOMALY VALUE 


GRID DIMENSIONS AS FOLLOWS: 
the following arrays - (ny+1 ) * (nx+1 ) : 
x,y, tp, ifc, ih, sep 

the following arrays must be equal to or greater than 
the maximum number of data points: 

rrad, rthi, rphi, tano, dist , thil, phii, radd, anom 
ARRAYS CNN, DNUM MUST ACCOMMODATE THE NUMBER OF ENTRIES 
IN COVARIANCE FUNCTION 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
IMPLICIT REAL (A-H, 0— Z ) 

DIMENSION X (20000) , Y (20000) , TP (20000) ,CNN(500}, 

DNUM (500) , RRAD (200000) , RTHI (200000) , RPHI (200000), 

TANO (200000) , 

DIST (200000) , IFC (20000) , thii (200000) , phii (200000) , 

> radd (200000) , ancm (200000) , IH (20000) ,SEP (20000) 

REAL NORTH 

real thi , phi, rad, ancm, cross 
integer totpts 
character*80 filename 
character*5 yesno 
real dnum, cnn, scale, sumsqr 
COMMON/ONE/ CNN, DNUM, NCOV 
C 0M40N / TWO / SCALE 
DATA RHO,NPTS/57. 2957795,0/ 
c 

write (*,*) ’INPUT COVARIANCE MATRIX' 
read (*,9990) filename 
9990 format (a80) 

open (1, file-filename, status-’ old' , form- ' formatted' ) 
write {*,*) 'INPUT FILE OF ALL DATA POINTS LAT LON RAD ANOM' 
read (*,9990) filename 

open (10, file-filename, status- ' old’ , form- ' formatted' ) 
write (*,*} 'OUTPUT FILE OF GRIDDED DATA POINTS' 
read (*,9990) filename 

open (20, file-filename, form- ' formatted’ ) 
write (*,*) ‘OUTPUT INFORMATION FILE' 
read (*,9990) filename 

open (21, file-filename, form- ' formatted' ) 


write (*,*) 'BARF — NORTH SOUTH EAST WEST AS 90.0 TO -90.0*, 

> ' AND 180.0 TO -100.0’ 

read (*,*} nor th, south, east , west 

write (*,*) ’NUMBER OF GRID POINTS MINUS ONE IN THE NS DIRECTION 

write (*,*) ’NUMBER EW 

write {*,*) 'NS, EW * 
read (*,*) ny,nx 

write (*,*) 'POINT SIZE OF WINDOW FOR SEARCH AREA (20)' 
read (*,*) ncpp 

write (*,*) 'ELEVATION OF PREDICTION FOR GRID (350.0 Km)' 
write (*,*) •(—NOT— radius - 6378.140 Km)' 
read (*,*) elev 
elev-elev+6378. 140 
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write (*,*} 'STANDARD DEVIATION OF OBSERVATIONAL ERROR (1.0)' 
read (*,*) estd 

write (*,*) 'REMOVE THE MEAN FROM THE GRID BEFORE WRITTING' 
write (*,*) *y OR n' 
read (*, 9991) yesno 
9991 format (a5) 

c 

If (EAST. EQ. WEST. OR. NORTH. LE. SOUTH. OR. NY. LE.O. OR. NX. 

. LE.O) STOP 9999 
C 

C CHANGE LATITUDES TO SPHERICAL COORDINATES 

C 

NORTH-90 . O-NORTH 
SOUTH-90. 0-SOUTH 
C 

c the program is checking for the -180.0 180.0 meridian 

c 

cross-0.0 

IF (WEST. GT. EAST) cross-360.0 
EAST-EAST + cross 
C 

C INPUT THE COVARIANCE TABLE 

C 

1-1 

5 read (1,*, end-7) dnum (i) , cnn (i) 

i-i + 1 
go to 5 
7 ncov-i-1 

SC ALE -CNN (1 ) 

C 

C GRID SPACING ..ie: interval between grid nodes - dl and dp 
C 

DP- (NORTH-SOUTH) /FLOAT (NY) 

DL- ( EAST-WEST ) /FLOAT (NX) 

C 

C . . DETERMINE THE OVERLAPS IN X AND Y-DIRECTIONS 
C 

YOVLAP-DP/2 . 

XOVLAP-DL/2. 

.. NXPl , NYP1 - NUMBER OF SORT ELEMENTS IN X AND Y-DIR. 

.. XLL,XUP - LOWER AND UPPER X LIMITS OF SORT RANGE 
.. YLL, YUP - LOWER AND UPPER Y LIMITS OF THE SORT RANGE 
.. NX, NY - NUMBER OF DIVISIONS ALONG X AND Y AXES 
DETERMINE X,Y COORDINATES OF GRID INTERSECTIONS 


NXPl -NX + 1 
NY PI -NY + 1 
DO 10 I -1 , NYPl 

YY-DP* (I-U+YOVLAP 
DO 10 J— 1 , NXPl 
K-J+NXPl* (1-1) 

Y (K) -YY 

X ( K) -DL* ( J-l ) ^XOVLAP 
10 CONTINUE 
C 

C DETERMINE THE X,Y COORDINATES OF THE DATA AREA AND 
C GRID SPACING 
C 

XLL-0. 

XUP-X (NXPl ) +XOVLAP 
YLL-0. 

YUP-Y (NXPl *NYP1 ) + YOVLAP 
DXX-NXP1/ (XUP-XLL) 

DYY-NYP 1 / (YUP -YLL) 

C 

C DETERMINE BOUNDARIES FOR DATA SELECTION 
C 

THIS- SOUTH -YOVLAP 
TH I N-NORTH+ YOVLAP 
EPHI-EAST+XOVLAP 
WPHI-WEST-XOVLAP 


c varn is a constant for input to subroutine 

c prdt. varn should be change to an array for 

c corresponding individual data points if each 

c data point or group of data points need to have 

c individually different error variances. 


varn-estd**2 

C 

write (21,*) 'north colatitude north, ' south colat south 
write (21,*) 'east longitude -',east, ' west long -',west 
write (21,*) 'dp -*,dp, ' dl -',dl, ' xovlap -',xovlap, 

> ' yovlap -*,yovlap 

write (21,*) 'thin -',thin,' this -',this,' ephi «',ephi, 

> ' wphi «',wphi 

write (21,*) 'xll -*,xll,' xup -' f xup,' yll -',yll, ' yup -*,yup 
write (21,*) ' dxx -*,dxx, * dyy -',dyy 

write (21,*) ‘error variance -',varn, 

> ' standard deviation error -',estd 
c 
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C INPUT ADJUSTED MAGNETIC DATA AND SELECT DATA FOR 
C THE PREDICTION 
C 

np- (nxpl+1 ) * (nypl+1) 
do 15 i-l,np 
ifc(i}-0 
15 continue 
c 

AMEAN-0. 0 
tOtpts-0 

20 read (10, *, end-30) t hi, phi, rad, anomaly 
totpts-totpts+1 
THI-90. 0-THI 

IF (THI .GE. THIS) GO TO 20 

IF (THI.LE.THIN) GO TO 20 

IF (PHI .LT. 0.0) PHI-PHI + cross 

IF (PHI .LE.WPHI ) GO TO 20 

IF (PHI .GE. EPHI ) GO TO 20 

NPTS-NPTS +■ 1 

AMEAN-AMEAN + anomaly 

RX-PHI-WPHI 

RY-THI-THIS 

IX AND IY IDENTIFIES THE BLOCK TO WHICH DATA FALL INTO 
AND IYJX ASSIGNS AN IDENTIFIER TO DATA CORRESPONDING TO 
THAT BLOCK 

IY-INT( (RY-YLL) *DYY)+1 
JX-INT ( (RX-XLL) *DXX)+1 
IYJX- (IY-1) ♦NXPl+JX 

.. IFC - COUNTER VECTOR , STORES NUMBER OF DATA PER 
SORT ELEMENT 

IFC (IYJX) -I FC (IY JX) +1 

thii (npts) -thi 
phii (npts) -phi 
radd (npts ) -rad 
anom (npts) -anomaly 

GO TO 20 

30 continue 

if (npts ,le. 1) stop 111 

AMEAN-AMEAN /FLOAT (NPTS) 

WRITE (21,*) ‘total points selected -',npts 
write (21,*) 'total points read -*,totpts 
write (21,*) 'mean of selected points -',amean 
write (*,*) 'finished reading data set' 

IH - POINTER VECTOR, FOR CORRESPONDING BLOCK ATTAINS 
A VALUE EQUAL TO SUM OF DATA IN PREVIOUS BLOCKS + 1 

ND-NXPl *NYPl 
IH (1 ) -1 
DO 07 1-2, ND 
Il-I-l 

IH (I ) -IFC (Il)+IH(Il) 

87 CONTINUE 
C 

C TX, TY, RTHI , RPHI , RRAD, TANO, VARN ARE NUMBERED FOR 
C CORRESPONDING DATA, IN EACH BLOCK NUMBERING STARTS 
C WITH IH VALUE FOR THAT BLOCK AND INCREMENTED BY 1 FOR 
C NEXT DATA IN THE BLOCK 
c 

c the mean anomaly value is removed here rather than in subroutine prdt. 
c also the sum of squares is calculated here and transfered to 
c subroutine prdt. 
c 

sumsqr-0. 0 
DO 85 I -1, NPTS 

rx-phii (i) -wphi 
ry-thii (i) -this 
IY«INT( (RY-YLL) *DYY)+1 
JX-INT { (RX-XLL) *DXX)+1 
IYJX- (I Y— 1 ) *NXP1+JX 
NUM-IH (IYJX) 

TANO (NUM) -anom (i ) -amean 

sumsqr-sumsqr+ (dble (tano(num) ) *dble (tano (num) ) ) 

RTHI (NUM) -thii (i) 

RPHI (NUM) -phii (i) 

RRAD (NUM) -radd(i) 

IH (IYJX)-IH(IYJX)+1 
85 CONTINUE 
C 

C IH (I) ATTAINS THE VALUE EQUAL TO NUMBER OF SAMPLE 
C POINTS IN PREVIOUS BLOCKS + 1 
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c 

DO 86 I -1 , ND 

IH(I)-IH(I)-IFC(I) 

86 CONTINUE 

IH (ND+1) -NPTS+1 
C 

C SUBROUTINE PRDT PREDICTS ANOMALIES AND ERRORS OF 
C STANDARD DEVIATION AT EACH GRID LOCATION 
C 
c 

write {*,*) ‘calculating anomaly values' 
c 

CALL PRDT(NPTS,NYPl,NXPl,X,Y,TP,RTHI, RPHI,DIST, 

VARN, THIS, TANO, NORTH, SOUTH, EAST, WEST, IH, DXX, DYY, DP, 

. DL, AMEAN, RRAD, NCPP, ELEV, SEP, sumsqr) 

c 

c 

C WRITE THE VALUES OF THE PREDICTED Z-AXIS VALUES 
C (ANOMALIES) AND THEIR ERROR OF STANDARD DEVIATIONS. 

C THE ROWS ARE LISTED WITH LATITUDES STARTING SOUTH 
C AND INCREMENTING TO NORTH, 
c 

if (yesno .eq. 'y') then 
np-nxpl *nypl 
do 380 i-l,np 

totgrid-tp (i) +totgrid 
380 continue 

avgrid-tot grid/real (np) 
do 390 i-l,np 

tp (i } -tp (I ) -avgrid 
390 continue 

write (21,*) 'total mean removed from the grid -*, avgrid 
endif 
c 

WRITE (21, 9600) WEST, DL 
write (20,*) nxpl 
write (20,*) nypl 
write (20,*) south 
write (20,*) west 
write (20,*) dl 
P-SOUTH 

DO 400 I-1,NYP1 

IDl-(I-l) *NXP1+1 
ID2-ID1+NXP1-1 

WRITE (21, 9601) P, (TP ( J) , J-IDl, ID2) 

WRITE (20, ' (6F13. 5) * ) (TP ( J) , J-IDl , ID2 ) 

400 P-P + DP 
C 

WRITE (21, 9602) WEST, DL 
P-SOUTH 

DO 420 1-1 , NYPl 

ID1- (1-1) *NXP1+1 
ID2-ID1 +NXP1 -1 

WRITE (21, ' (6F13. 5) ' ) (SEP { J) , J-IDl , ID2 ) 

420 P-P + DP 
C 

9600 FORMAT {/, 'PREDICTED Z-AXIS VALUES 1 ,/, 

•STARTING LONGITUDE- ',F9. 3, ' ; INCREMENT- ', F5 . 2, / ) 

9601 FORMAT ( * LAT- ' , F8 . 2, 2X, 80 (8F8 . 2, /, 14X) ) 

9602 FORMAT (/, 'PREDICTED STANDARD DEVIATIONS',/, 

. 'STARTING LONGITUDE-' ,F 9.3, '; INCREMENT- ', F5. 2, /) 

c 

STOP 

END 

c 

c 

c 

c 

SUBROUTINE PRDT (NPTP,MY,MX, X, Y,TP, LAT, LONG, DIST, 

NSEe, THIS,M1,THI1,THI2,PHI1,PHI2, I H, DXX, DYY, DP, DL, 
AMEAN, RC, NCPP, ELEV, SEP, sumsqr ) 

IMPLICIT REAL (A-H,0-Z) 

REAL NSEe, LAT, LONG, Ml 

real scale, covm, fact, sumsqr, var, nse, dummy, b, 


> tl, t 2, tem, tem2, cov 

DIMENSION LAT (1), LONG (1), DIST (1), Ml (1) ,RC(1), 

> X(1),Y(1),TP(1),IH(1), SEP (1 ) 

DIMENSION COVM (110, 110) ,B (110) ,T1 (110) ,T2 (1 10) , LCC (110) 
COW40N/TWO/ SCALE 
DATA DMAX/6E6/ 

EQUIVALENCE (B (1 ) , Tl (1 ) ) 

c subroutine description 

c this subroutine is one big do loop that progresses through 

c the grid nodes to determine the magnitude at each node, 

c 


nse-dble (nsee) 
CON1-57. 2957795 
ND-MY*MX 
NBAD-0 
YLL-0.0 
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XLL-0.0 

C 

C CALCULATE THE SCALING FACTOR FOR THE COVARIANCE TABLE 
C 

fact - (sumsqr/dble (nptp) ) /scale 
c 

CALL COVINT (0.0, FACT, VAR) 
c 

write (21,*) 'sum of squares -^sumsqr, 1 scaling factor - ' , FACT 
write (21,*)'zero separation variance -',var 
c 

NCPMl-NCPP-1 

IND-0 

C 

C P AND Q ARE THE LATITUDE AND LONGITUDE OF THE 
C PREDICTED POINT 
C 

write (21,*) ' * 

write (21, *} 'the following data indicate areas where the' 
write (21,*) 'prediction was bad* 

write (21,*) 'lat Ion x grid node y gridnode idl id2 
> 'bad point number of total points' 

c 

DO 10 IPT-1,MY 
IM-IPT-1 
P«THI2+IM*DP 
DO 10 JPT-1, MX 
JM-JPT’l 
Q-PHI2+JM*DL 
IND-IND+1 
XPP-X(IND) 

YPP-Y(IND) 

DO 7 1-1, NCPP 
7 LCC (I) “0 

C 

C DISTANCE TO ALL POINTS IN THE WINDOW FROM PREDICTION 
C POINT 
C 

IY-INT ( (YPP-YLL) *DYY) +1 
JX-INT ( (XPP-XLL) *DXX) +1 
IYJX- (IY-1) *MX+JX 
IDl-IH (IYJX) 

ID2-IH (IYJX+1) 

IF ( (ID2-ID1 ) . GE . NCPP) GO TO 100 
C 

C NOT ENOUGH DATA IN FIRST WINDOW, SO CONSIDER NEXT 
C WINDOW 

C 

IY1-IY 

IY2-IY 

DO 17 IC-1 , MY 
NDATA-0 
IY1-IY-IC 
IY2-IY+IC 

IF(IYl.LT.l) IY1-1 
IF (IY2.GT.MY) IY2-MY 
JXl-JX-IC 
JX2-JX+IC 

IF (JXl . LT. 1 ) JX1-1 
IF (JX2.GT.MX) JX2-MX 
DO 18 IL-IY1, IY2 

IYJXl-(IL-l) *MX + JXl 
IDl-IH(lYJXl) 

IY JX2-IYJX1+ JX2-JX1+1 
ID2-IH (IYJX2) 

NDATA-NDATA+ ID2-ID1 


18 CONTINUE 

IF (NDATA.GE.NCPP) GO TO 100 
NBAD-NBAD+1 

c write the bad point to file 

c 

WRITE (21, 800) P, Q, XPP, YPP, IDl, ID2 , NBAD, ND 
800 FORMAT (4 (lx, F12 . 5} , 416) 

17 CONTINUE 

100 CONTINUE 


DO 211 IC-IY1 , IY2 

IF (I Yl . EQ. IY2 ) GO TO 106 
IY JXl - (IC-1 ) *MX+ JXl 
IDl-IH(IYJXl) 

IYJX2-IYJX1+JX2-JX1+1 
ID2-IH (IYJX2 ) -1 
IF (ID2.LT.ID1) GO TO 211 
106 DO 210 I-IDl , ID2 

DELC-COS (LAT (I } /CONI ) *COS (P/CONl ) +SIN (LAT (I ) /CONI ) * 
> SIN (P/CONl) *COS( (LONG (I) -Q) /CONI) 

PART1-ELEV**2 + RC(I}**2 
PART2-2 . 0* ELEV* RC < I ) 

DARGU-PART1-PART2*DELC 
IF (DARGU.LE.0.0) THEN 
DIST (I ) -0 . 0 
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ELSE 

DIST (I)-SQRT (DARGU) 

END IF 

210 CONTINUE 

211 CONTINUE 

SEARCH FOR NCPP NEAREST POINTS TO PREDICTION POINT 

220 DO 260 J-l, NCPP 

IF (LCC(J) .GT.O) GO TO 260 

DMIN-DMAX 

DO 253 IC-IY1 , IY2 

IF (IY1.EQ.IY2) GO TO 107 
IYJX1- (IC-1) *MX + JXl 
ID1-IH (IY JX1 ) 

IYJX2-IYJX1+JX2-JX1+1 
ID2-IH (IYJX2 ) -1 
IF (ID2.LT. ID1) GO TO 253 
107 DO 250 I-ID1 , ID2 

IF (DIST (I ) -DMIN) 230, 250, 250 
230 IF (DIST (I ) } 250,240,240 

240 DMIN-DIST(I) 

LMIN-I 

250 CONTINUE 

253 CONTINUE 

DIST (LMIN) —DMIN 
LCC(J)-IMIN 
260 CONTINUE 

IF (LCC(NCPP) .NE.0) GO TO 258 
GO TO 220 

258 CONTINUE 


FORM COVARIANCE MATRIX 

DO 280 1-1 , NCPM1 
M-LCC(I) 

COVM (1,1) -dble (VAR+NSE) 

K-I + l 

DO 280 J-K, NCPP 
N-LCC(J) 

DELC-COS (LAT (M) /CONI ) *COS ( LAT (N) /CONI ) + SIN (LAT (M) / 

CONI) *SIN (LAT (N) /CONI) *C0S( (LONG (M) 

> -LONG (N) ) /CONI) 

PARTl-RC (M) **2 4 RC (N) **2 
PART2-2.0*RC (M) *RC (N) 

DARGU-PART1-PART2*DELC 
IF (DARGU.LE.0.0) THEN 
DIS-0.0 
ELSE 

D IS- SORT (DARGU) 

END IF 

CALL COVINT (DIS, FACT,COV) 

COVM (J, I) -dble (COV) 

COVM (I, J)-dble(COV) 

280 CONTINUE 

COVM (NCPP, NCPP) -dble (VAR+NSE) 

covm array dimensioned at 

(ncpp,ncpp) is the input matrix 


INVERT COVARIANCE MATRIX 

COVM ( 1 , 1 ) "1 . 0/COVM (1,1) 

DO 340 I-l, NCPMl 
L-I+l 

DO 300 J-l, I 

300 B ( J) -0 . 0 

DO 310 J-l, I 
DO 310 K-l , I 

310 B ( J) -B ( J) -COVM (K, J) *COVM (L, K) 

Dummy -COVM (L, L) 

DO 320 J-l, I 

320 Dummy-B (J) *COVM(L, J) +Dummy 

Dummy-1 .0/Dummy 
DO 330 J-l, I 

COVM ( J, L) -B { J) * Dummy 
COVM (L, J) -B ( J) *Dummy 
DO 330 K-l, I 

330 COVM (J,K) -COVM (J,K)+B(K) *B(J) ‘Dummy 

340 COVM (L, L) -Dummy 


covm array dimensioned at 
(ncpp, ncpp) is now inverted 


DO 410 1-1 , NCPP 
N-LCC(I) 

DELC-COS (LAT (N) /CONI ) ‘COS (P/CONI ) +SIN (LAT (N) /CONI } * 
SIN (P/CONI ) ‘COS ( (LONG (N) -Q) /CONI ) 

PARTl-RC (N) “2 + ELEV* *2 
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PART2-2.0*ELEV*RC(N) 

DARG U -PART 1 -PART 2 * D ELC 
IF (DARGU.LE.0.0) THEN 
DIS-0.0 
ELSE 

D I S-SQRT (DARGU) 

END IF 

CALL COVINT (DIS, FACT, COV) 

410 T1 (I)-dble (COV) 

DO 430 I-1,NCPP 
TEM-0.0 

DO 420 J-1,NCPP 

420 TEM-COVM ( J, I ) *Tl ( J> +TEM 

430 T2(I)-TEM 

TEM-0.0 
TEM2-0.0 
DO 440 I-1,NCPP 
M-LCC (I) 

TEM-dble (Ml (M) ) *T2 (I) +TEM 
TEM2-T1 (I)*T2(I)+TEM 2 
440 CONTINUE 

COMPUTE ANOMALY ESTIMATE AND STANDARD ERROR OF PREDICTION 

TP (IND) -real (TEM) +AMEAN 
IF (VAR. LT.TEM2) GO TO 444 
SEP (IND) -SQRT (VAR-TEM2 ) 

GO TO 445 

444 SEP (IND } -1 . 5 

WRITE (21,446) VAR, TEM2 

446 FORMAT (‘VARIANCE - • , F7 . 2 , ' TEM2 , F7 . 2, 1 SEP ' , 

. ' TAKEN AS 1.5 NT') 

445 CONTINUE 
10 CONTINUE 

RETURN 

END 


SUBROUTINE COVINT (DIS, FACT, COV) 

IMPLICIT REAL (A-H,0-Z> 
real dis 
Integer ncov 

DIMENSION CNN (500 ) , DNUM (500) 

COMMON/ONE/ CNN, DNUM, NCOV 
c 

C INTERPOLATION OF COVARIANCES 

TCOV-dble (NCOV-1) 

Rl-dble (DIS) 

IF (Rl . LT.TCOV) GO TO 1 
COV -CNN (NCOV) *FACT 
WRITE (21,100) Rl 
RETURN 
c 

1 IF (Rl .GT. 0.0001) GO TO 6 
COV-CNN (1 ) *FACT 

RETURN 

c 

6 DO 2 I -1, NCOV 

IF (Rl.LT.DNUM(I) ) GO TO 3 

2 CONTINUE 

3 I-I-l 

FP INT-Rl -DNUM ( I ) 

FD I NT -DNUM (1+1 ) -DNUM (I) 

COV-CNN ( 1 ) 4 - (CNN (1+1 ) —CNN (I ) ) *FPINT/FDINT 
COV-COV*FACT 
RETURN 
c 

100 FORMAT (' SEPARATION -\F10.3, ' >500 KM COVARIANCE VALUE FOR*, 

> ' 500 KM USED. 1 ) 

c 

END 
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c- 

c 

c 
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c 
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c 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


program fourier2d 
character*80 filename 

real xdata (361, 361) ,ydata (361,361) ,xmean,ymean, 

> prcnt, delta, cutni, cutlo, xlag, mince, maxcc, short, long, 

> xcolat,ycolat, xlong, y long, xgridspc, ygridspc, 

> minccin,maxccin, cxlag 

integer xpassno,ypassno, f ile, xcol, xrow, ycol, yrow, 

> Inb, cc, npass, imean, head, spass, swind, 

> nwind, numfile, nxout, nyout, enwind, udnwind, 

> numcc (10) , numlhb (10) ,numsd(10) , numud (10) , numrtp (10) , 

> numderiv (10) 

complex xedata (512, 512) ,ycdata (512, 512) 
common /rowcol/ xrow, xcol, yrow, ycol 

common /fftifft/ nxout, nyout, prcnt, imean, fold, itypef old 
ccmmon /lhbflt/ delta, cuthi, cutlo, xlag, npass, nwind 
common /ccflt/ mince, maxcc, minccin,maxccin, enwind, cxlag 
common /reals/ xdata, ydata 

ccmmon /striking/ angl,ang2, spass, swind, slag 
ccmmon /udeont/ uddelta, zcon, udxlag, udnwind 
common /xyzderiv/ xyzdelta, nth, nway 
common /rtp/ azm,xinc,dec 
common /comps/ xedata, yedata 

program description 

fourier2d is an all encompassing fourier analysis program! 
subroutines include the fft for forward and inverse situations, 
a bandpass filter which can be adjusted to perform low, high and 
bandpass filtering of wave numbers, a correlation coefficient 
filter which zeros out wavenumbers according to correlation 
coefficients, a strike-dip filter to remove wavelengths in 
degrees of direction, an upward-downward continuation filter, 
a derivative filter for any of the three directions and a 
reduction-to-pole filter for magnetic total field intensity data. 

NOTE: the only data variables absolutely necessary as INPUT are 
the number of rows and number of columns, the remaining 
variables; zero, mean, pass-number and eight, are not needed, 
but, mean can be an OUTPUT if desired. 

NOTE: fourier2d is for two-dimensional data, if you have a 
one-dimensional data set then use fourierld. however, 
in 1-d i have not yet implemented the continuation, 
derivative or rtp filters. 

program date: 10 jul 92 

this code was an extensive modification of an earlier code 
named fourmat. 


NOTE: because there are 6 filters, there are about forty 

zillion different combinations of filtering the fft'd 

data. so, to acccnadate all of these, the user must 

first state how many times to run the filter (ilhb, 

icc, etc) then must state the order where to run each 

filter (arrays numlhb, numcc, num etc., hold these 

user defined positions) . note that with this scheme 

any filter can be run multiple times, be sure to enter 

only one filter for each position value, the 

following example should clear things up: 

say you want to first bandpass filter, then cc 

filter and then bandpass filter again, then you 

should set ilhb-2 and icc-1. then array numlhb should 

have the values 1 and 3 (for the first and third positions) 

and array numcc should only have the value 2 (for the 

second position. 


write (*,*) 'OUTPUT FILE OF STATISTICS AND INFORMATION' 
read (*,9990) filename 

open (25, file-filename, form- ' formatted* ) 
write (*,9989) 

9989 format ('1 IF YOU HAVE ONLY ONE FILE TO BE FOURIERED ' /, 
> *2 IF YOU HAVE TWO FILES TO BE COMPARED') 

read (*,*) numfile 


write (*,9988) 

9988 format ('ENTER THE MAXIMUM NUMBER OF TIMES TO RUN EACH FILTER'/, 

> 'ENTER 0 TO NOT RUN THE FILTER'/, 

> 'BANDPASS, CORR. COEFF. , STRIKE-DIP, UP/DNCONT., RTP, DERIV ' ) 
read (*,*) ilhb, icc, isd, iud, irtp, ideriv 

c 

if (ilhb .gt. 0) then 

write (*,*) 'BANDPASS SECTION:' 

write (*,*) 'enter placement values in order ie. 2 3 5 * 
write (*,*) 'do not repeat these values elsewhere' 
write (*,*) '1-first, 3-third, 5-fifth etc. ' 
read (*,*) (numlhb (i) , i-1, ilhb) 
write (*,9993) 

9993 format {'DELTA GRID INTERVAL IN MAP UNITS (1.0 degrees)'/ 

> 'SHORT SHORTEST WAVELENGTH TO BE PASSED'/ 
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> • MUST BE AT LEAST 2* DELTA (2.0 degrees)'/ 

> 'LONG LONGEST WAVELENGTH TO BE PASSED'/ 

> • MUST BE LARGER THAN SHORT'/ 

> ' NPASS -1 TO REJECT WAVELENGTHS BETWEEN SHORT'/ 

> • AND LONG'/ 

> ' 1 TO PASS WAVELENGTHS BETWEEN SHORT AND'/ 

> ' LONG ' / 

> 1 NOTE *. WAVENUMBER - 1 /WAVELENGTH AND IS '/ 

> • CALCULATED BY THE PROGRAM'/ 

> • INPUT ORDER IS DELTA SHORT LONG NPASS') 


read 

write 
9994 format ( 
> 

> 

> 

> 

> 

> 

> 

> 

> 

read 


(*,*) delta, short, long, npass 
(*,9994) 

• NWIND TYPE OF WINDOW TO APPLY'/ 

• - 0 GIVES NO WINDOW'/ 

• - 1 RECTANGULAR WINDOW'/ 

• - 2 BARTLETT WINDOW (TRIANGULAR) ' / 

' - 3 HAMMING -TUKEY WINDOW'/ 

' - 4 PARZEN WINDOW'/ 

• XLAG SMOOTHING PARAMETER FOR WINDOWING IDEAL'/ 

' FILTER IN SPATIAL DOMAIN (is disabled if’/ 

• no window was chosen above).'/ 

' nwind xlag') 

(*,*) nwind, xlag 


cuthi-1 .0/short 
cutlo-1 .0/long 
RCUTLO- 99 9 99 9. 99 

IF (CUTLO .GE. 0.0000001 ) RCUTLO- 1.0/CUTLO 

RCUTHI-1.0/CUTHI 

WAVLEN- 2.0* DELTA 

FNQl-1 .0 /WAVLEN 

WRITE (25,9987) FNQ1 , WAVLEN, CUTLO, RCUTLO, CUTHI, RCUTHI 
9987 FORMAT ( ' NYQUIST WAVENUMBER -',F10.5,' CYCLES PER DATA INTERVAL'/, 

> 'NYQUIST WAVELENGTH - \F10.5, ' LENGTH INTERVALS'/, 

> 'LOW WAVE# CUTOFF OF IDEAL FILTER - ',F10.5, 

> ' CYCLES PER DATA INTERVAL '/,F15.5, 

> ' WAVELENGTH EQUIVALENT'/, 

> 'HIGH WAVE# CUTOFF OF IDEAL FILTER - *,F10.5, 

> ' CYCLES PER DATA INTERVAL '/,F15.5, 

> » WAVELENGTH EQUIVALENT',//) 

endif 


if (icc .gt. 0) then 

if (numfile .ne. 2} then 

write (*,*) 'you must enter two files to run cc filter' 
stop 


endif 
write 
write 
write 
write 
read ( 
write 
9995 format ( 

> 

> 

> 

> 

> 

> 

> 

> 

> 


(*,*) 


<*,*) 

(*,*> 


3 5 


'/, 

’/, 


read 

endif 


•CORRELATION COEFFICIENT SECTION: ' 

'enter placement values in order ie. 2 
'do not repeat these values elsewhere' 

'1-first, 3-third, 5-fifth etc...' 

*,*) (numcc (i) , i-1, icc) 

(*,9995) 

WHAT IS THE MINIMUM CORR COEF TO BE PASSED: (0.4) ' 

WHAT IS THE MAXIMUM CORR COEF TO BE PASSED: (1.0) ' 
MINIMUM INPUT CC WITHOUT WRITING WARNING'/, 

MAXIMUM INPUT CC WITHOUT WRITING WARNING'/, 

CNWIND TYPE OF WINDOW TO APPLY’/ 

- 0 GIVES NO WINDOW*/ 

- 1 RECTANGULAR WINDOW'/ 

- 2 BARTLETT WINDOW (TRIANGULAR) ' / 

- 3 HAMMING-TUKEY WINDOW'/ 

- 4 PARZEN WINDOW'/ 

CXLAG SMOOTHING PARAMETER FOR WINDOWING IDEAL'/ 

FILTER IN SPATIAL DOMAIN (is disabled if'/ 
no window was chosen above).'/ 
mince maxcc minccin maxccin enwind cxlag' ) 

;*, * ) mince, maxcc, minccin, maxccin, enwind, cxlag 


if (isd .gt. 0) then 

write (*,*) 'STRIKE-DIP SECTION:' 

write (*,*) 'enter placement values in order ie. 235' 
write (*,*) 'do not repeat these values elsewhere' 
write (*,*) 'l-first, 3-third, 5-fifth etc...' 
read (*,*> (numsd (i) , i-1, isd) 
write (*,9986) 

9986 format ('ANGLE 1: >- 0.0 AND < ANGLE2 ' /, 

> 'ANGLE 2: > ANGLE 1 AND <- 180.0'/, 

> ' 1 TO PASS AZIMUTHS BETWEEN ANGLES'/, 

> '-1 TO REJECT AZIMUTHS BETWEEN ANGLES'/, 

> 'TYPE OF WINDOW TO APPLY TO FILTER'/, 

>' 0 (NONE), 1 (RECTANGULAR), 2 (TRIANGULAR), 3 (H-T) , 4 (PARZEN)'/, 

> 'LAG VALUE ON SMOOTHING WINDOW (0.1 TO 99.9)'/, 

> ' angl ang2 spass swind slag' ) 
read (*,*) angl, ang2, spass, swind, slag 

endif 


c 

if (iud .gt. 0) then 

write (*,*) 'UP/DCWN CONTINUATION SECTION: ' 
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write (*,*) 'enter placement values in order ie. 2 3 5 * 
write (*,*) 'do not repeat these values elsewhere' 
write {*,*) '1-first, 3-third, 5-fifth etc. .. • 
read (*,*) (numud (i) , i-1 , iud) 
write (*,9985) 

9985 format (' udDELTA - GRID INTERVAL IN MAP UNITS (1.0)'/, 

> 1 ZCON - DISTANCE TO CONTINUE THE DATA SET'/, 

> ' IN THE SAME LENGTH UNITS AS DELTA'/, 

> • (1.0 degree - 111 km)'/, 

> • NEGATIVE FOR UPWARD CONTINUATION'/, 

> ' POSITIVE FOR DOWNWARD CONTINUATION'/, 

> ' udNWIND - TYPE OF WINDOW TO APPLY TO FILTER'/, 

> • 0 (NONE), 1 (RECTANGULAR), 2 (TRIANGULAR)'/, 

> ' 3 (H-T), 4 (PARZEN) ' /, 

> ' udXLAG - SMOOTHING PARAMETER FOR WINDOWING FILTER'/, 

> ' IN SPATIAL DOMAIN. DETERMINES WHAT PERCENTAGE'/, 

> ' DATA IS WINDOWED'/, 

> * delta zcon udnwind udxlag') 
read (*,*) uddelta, zcon, udnwind, udxlag 

endif 

if (irtp .gt. 0} then 

write (*,*) 'REDUCTION TO POLE SECTION:' 

write {*,*} 'enter placement values in order ie. 2 3 5 * 

write {*,*) 'do not repeat these values elsewhere' 

write (*,*) '1-first, 3-third, 5-fifth etc. ' 

read (*,*) (numrtp (i) , i-1 , irtp) 

write (*,9983) 

9983 format ('AZM - AZIMUTH OF Y AXIS MEASURED IN DEGREES'/, 

> • CLOCKWISE FROM TRUE NORTH'/, 

> 'DEC - AVERAGE DECLINATION OF THE INPUTTED'/, 

> ' ANOMALY DATA'/, 

> 'XINC - AVERAGE INCLINATION OF THE INPUTTED'/, 

> ' ANOMALY DATA'/, 

> 'azm dec xinc') 
read (*,*) azm, dec, xinc 

endif 


if (ideriv .gt. 0) then 

write (*,*) 'DERIVATIVE SECTION:' 

write (*,*) 'enter placement values in order ie. 235' 
write (*,*) 'do not repeat these values elsewhere' 
write (*,*) 'l-first, 3-third, 5-fifth etc...' 
read (*,*) (numderiv (i ), i-1 , ideriv) 
write (*,9984) 

9984 format ( ' xyzDELTA - GRID INTERVAL'/, 

> 'NTH - ORDER OF SPATIAL DERIVATIVE TO PERFORM'/, 

> ' ON THE DATA'/, 

> ' NWAY - DIRECTION IN WHICH TO CALCULATE THE*/, 

> ' DERIVATIVE'/, 

> ' 0 - VERTICAL DERIVATIVE'/, 

> ' 1 - HORIZONTAL DERIVATIVE IN "X" DIRECTION'/, 

> ' 2 - HORIZONTAL DERIVATIVE IN "Y" DIRECTION'/, 

> 'xyzdelta nth nway') 
read (*,*) xyzdelta, nth, nway 

endif 

c 

write (*,9992) 

9992 format ('THE FOLLOWING REFERS TO FFT AND IFFT' //, 

> 'NUMBER OF COLUMNS AND ROWS OF FFT ARRAY'/, 

> 'AT A POWER OF 2: (256 128) (2 16 32 64 128 256 etc)*/, 

> 'TYPE OF INPUT ARRAY INDICATES TYPE OF FOLDING TO BE USED'/, 

> ' 0 IF A POLAR REGION, ie. E AND W EDGES ARE SAME'/, 

> ' 1 IF A NON-POLAR REGION, ie . E AND W EDGES NOT SAME'/, 

> 'PERCENT OF EACH EDGE OF INPUT ARRAY TO'/, 

> 'BE FOLDED OUT: (0.1 TO 99.9)'/, 

> ‘PERCENT OF EACH EDGE OF FOLDED OUT OR NORMAL ARRAY'/, 

> 'TO BE SMOOTHED TO ZERO: (0.1 TO 49.9)'/, 

> '0 DO NOT ADD MEAN TO IFFT DATA'/, 

> '1 ADD MEAN TO IFFT DATA'/, 

> ' nxout nyout itypefold fold prcnt imean') 
read (*,*) nxout, nyout , itypefold, fold, prcnt , imean 

c 

If (nxout .gt. 512 .or. nyout .gt. 512) then 
write (*,8999) nxout, nyout 

8999 format (lx, ' SORRY ' ,16, lx, *OR* , i6, lx, ' IS GREATER THAN 512 THE', 

> ' SIZE OF ARRAYS SET'/* IN THE SOURCE CODE 

> 'YOU NEED TO ACCESS SOURCE CODE AND MAKE CHANGES') 
stop 

endif 

c 

c 

write (*,*) 'INPUT FILE 1' 
read (*,9990) filename 
9990 format (a8Q) 

open (10, file-filename, status- ' old' , form- ' formatted' ) 
if (numfile ,eq. 2) then 

write (*,*} 'INPUT FILE 2' 
read (*,9990) filename 

open (11, file-filename, status-'old' , form-' formatted' ) 


C-12 



endif 

write (*,*) ' OUTPUT Of FILE 1' 

read {*,9990) filename 

open (20, file-filename, form- 1 formatted' ) 
if (numfile .eq. 2) then 

write (*,*) 'OUTPUT OF FILE 2' 
read (*,9990) filename 

open (21, file-filename, form-' formatted' ) 
endif 
c 
c 

210 continue 

read (10,*) xcol 
read (10,*) xrow 
read (10,*) xcolat 
read (10, * ) xlong 
read (10,*) xgridspc 
if (numfile .eq. 2) then 
read (11,*) ycol 

read (11,*) yrow 

read (11,*) ycolat 

read (11, *} ylong 

read (11,*) ygridspc 
endif 
c 

xpassno- 1 
ypassno-2 
do i-l,xrow 

read (10,*) (xdata ( j, i ) , j-1, xcol) 
enddo 

if (numfile .eq. 2) then 
do i-l,yrow 

read (11,*) (ydata { j, i ), J-1, ycol) 
enddo 
endif 
c 

xmean-0. 0 

call forwardft (l,xmean, xpassno) 
ymean-0. 0 

if (numfile .eq. 2) call forwardft (2, ymean, ypassno) 
c 

itottime-ilhb+icc+isd+iud+irtp+ideriv 
do i-l,itottime 
do j-1, llhb 

) if (numlhb(j) .eq. i) then 

call filter (1) 

if (numfile .eq. 2) call filter (2) 
goto 888 
endif 
enddo 

do j*l,icc 

if (numcc(j) .eq. i) then 

call cor relate (xpassno, ypassno) 
goto 888 
endif 
enddo 

do j-l,isd 

if (numsd(j) .eq. i) then 
call strkpas(l) 

if (numfile .eq. 2) call strkpas(2) 
goto 888 
endif 
enddo 

do j-l,iud 

if (numud(j) .eq. i) then 
call upcon(l) 

if (numfile .eq. 2) call upcon{2) 
goto 888 
endif 
enddo 

do j-l,irtp 

if (numrtp(j) .eq. i) then 
call mag2pol(l) 

if (numfile .eq. 2) call mag2pol(2) 
goto 888 
endif 
enddo 

do j-l,ideriv 

if (numderiv(j) .eq. i) then 
call deriva(l) 

if (numfile .eq. 2} call deriva{2) 
goto 888 
endif 
enddo 
c 

888 continue 

enddo 
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c 

c 

call inverseft (1, xmean, xpassno) 

if (numfile .eq. 2} call inverseft (2,ymean,ypassno) 
c 

write (20,*) xcol 
write (20,*) xrow 
write (20,*) xcolat 
write (20,*) xlong 
write (20,*) xgridspc 
do i-1 , xrow 

write (20,9981) (xdata ( j, i) , j-1, xcol) 
enddo 

9981 format (5 (f 12 . 6, lx) ) 

if (numfile .eq. 2) then 
write (21,*) ycol 
write (21,*) yrow 
write (21,*) ycolat 
write (21,*) ylong 

write (21,*) ygridspc 
do i-1, yrow 

write (21,9981) (ydata ( j, i) , j-1 , ycol) 
enddo 
endlf 
c 

999 continue 
close (10) 
close (11) 
close (20) 
close (21) 
close (25) 
stop 
end 
c 


c 

subroutine forwardft (num,mean, passno) 

integer num, xrow, xcol, yrow, ycol, nxout , nyout, passno, 

> row, col 

real xdata (361, 361) , ydata (361,361 } ,prcnt,mean 
complex xcdata (512, 512 ) , ycdata (512,512) 

common /fftifft/ nxout, nyout, prcnt, imean, fold, itypefold 

common /rowcol/ xrow, xcol, yrow, ycol 

common /reals/ xdata, ydata 

common /comps/ xcdata, ycdata 

COMMON H (512, 512) 

DIMENSION X(2, 512,512) 

COMPLEX H 

double precision TSUM 
EQUIVALENCE (X (1 , 1 , 1 ) , H (1 , 1 ) ) 
c 

TSUM-0.D0 

if (num .eq. 1) then 
row-xrow 
col-xcol 
do 50 i-1, row 
do 50 j-1, col 

x (1, j, i) - xdata ( j, i) 
tsum-tsum+x (1, j, i) 

50 continue 

elseif (num .eq. 2) then 
row-yrow 
col -ycol 
do 80 i-1, row 
do 80 j-1, col 

x(l, j,i) - ydata (j,i) 
tsum=tsum+x (1, j, i) 

80 continue 

endif 
c 

£**•***********************************»********+********#*★******★** 


C 

C PROGRAM SPA2FRQ 

C 

C PROGRAM SPA2FRQ TRANSFORMS AN N X N MATRIX OF SPACE-DOMAIN 

C AMPLITUDES INTO THE N X N MATRIX OF WAVE NUMBER DOMAIN 

C COEFFICIENTS. THE TRANSFORM MAY BE USED BY FIVE 
C IN-CORE PROGRAMS TO PERFORM SPECTRAL OPERATIONS (UPCON, MAGPOL, 

C BANDPASS, STRKPASS, DERIV) . FUNCTIONS PERFORMED BY THIS PROGRAM 

C INCLUDE : 

C - REMOVAL OF THE MEAN FROM THE DATA 

C - OPTIONAL WINDOWING OF THE EDGES OF THE DATA SET 

C - PADDING OF THE DATA SET WITH ZEROES TO ACHIEVE NECCESSARY 

C SIZE (A POWER OF TWO) 

C - FORWARD TRANSFORM OF THE DATA 

C 

C REQUIRED SUBROUTINES : 

C 

C FFT2D, FORK, DATWND 
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c 

C DIMENSIONING REQUIREMENTS : 

C 

C X(2,N,N) WHERE N IS THE NUMBER OF COLUMNS AND ROWS OF THE 

C H (N,N) OUTPUT TRANSFORMED MATRIX. N MUST BE AN INTEGRAL 

C POWER OF TWO (2,4,8,16...). 

C NOTE : DIMENSIONS IN EVERY SUBROUTINE MUST BE 

C SET EQUAL TO DIMENSIONS IN MAIN PROGRAM. 

C 

C AUTHOR : SUBROUTINES FFT2D AND FORK ARE MODIFIED FROM JON REED, 

C PURDUE UNIVERSITY, DECEMBER 1980. 

C ALL OTHER CODE WRITTEN BY: 

C JEFFREY E. LUCIUS 

C GEOPHYSICAL INTERACTIVE COMPUTING LABORATORY 

C DEPARTMENT OF GEOLOGY AND MINERALOGY 

C THE OHIO STATE UNIVERSITY 

C COLUMBUS, OHIO 43210 

C 

C MARCH 25, 1905 (REVISED DEC 5, 1986) 

C 

c revised once again for DEC workstations on 6 APR 90 so that 

c that this beast is actually user friendly! 

c 

c revised again (judas priest this is getting old) on 

c 1 AUG 90 Into this present format of all fourier programs 

c combined into this program. 


C******************************************************************* 

C 

IF (2**INT (ALOG (FLOAT (NXOUT) ) /ALOG (2 .0) +0 . 01 ) .NE.NXOUT) THEN 
WRITE (6, 1030} 

STOP 

ENDIF 

IF (2** INT (ALOG (FLOAT (NY OUT) ) /ALOG { 2 . 0} +0 . 01 ) .NE.NYOUT) THEN 
WRITE (6, 1040) 

STOP 

ENDIF 

C 

C CALCULATE AND REMOVE THE MEAN 

C 

nxin-col 

nyin-row 

ICOL-nxin 

IRCW-nyin 

XMEANl -TSUM/FLOAT (NXIN*NYIN) 

DO 210 IY-1 , NYIN 
DO 210 IX-1 , NXIN 

X (1, IX, IY)-X(1, IX, IY) -XMEANl 
210 CONTINUE 


C WRITE (25, 1020) XMEANl 

C 

C WINDOW THE EDGES VIA DATWND 

C 

CALL DATWND (PRCNT, NXIN, NYIN, NXOUT, NYOUT, fold, itypefold) 
c 

c MATRIX IS NOW ZERO FILLED TO NXOUT BY NYOUT SIZE 

C CALCULATE AND REMOVE THE MEAN INTRODUCED BY TAPERING 

C 

TSUM-0.D0 
DO 214 IY-1, NYOUT 
DO 214 IX-1, NXOUT 
TSUM-TSUM+X(l f IX, IY) 


214 CONTINUE 

XMEAN 2 -TSUM/FLOAT (NXOUT* NYOUT ) 

DO 215 IY-1, NYOUT 
DO 215 IX-1, NXOUT 

X (1, IX, IY)-X(1, IX, I Y } -XMEAN2 

215 CONTINUE 

C WRITE (25, 1020} XMEAN2 

XMEAN -XMEAN 2 + XMEANl 
c WRITE (25, 1080) XMEAN 

write (25,*) passno, xmeanl , xmean2, xmean 
C 

C TRANSFORM DATA TO THE WAVENUMBER DOMAIN 

C 

NX -NXOUT 
NY -NYOUT 

CALL FFT2D (NX, NY, -1 ) 

C 

mean-xmean 
if (num ,eq. 1) then 
do 500 iy-l,ny 
do 500 ix-l,nx 

xcdata (ix, iy) - h(ix,iy) 

500 continue 

elseif (num .eq. 2) then 
do 580 iy-l,ny 
do 580 ix-l,nx 

ycdata (ix, iy) - h(ix,iy) 

580 continue 

endif 
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return 


c 

1020 FORMAT ( ’ MEAN REMOVED ',F15.7) 

1030 FORMAT (1H , 'NXOUT MUST BE A POWER OF 2: SPA2FRQ FATAL') 

1040 FORMAT (1H , 'NYOUT MUST BE A POWER OF 2: SPA2FRQ FATAL') 

1080 FORMAT ('TOTAL MEAN REMOVED ' ,F15.7) 

C 

END 

C 

c********* ***************************************************** ********* 

c 

SUBROUTINE FFT2D (NX, NY, NSIGN) 

C 

Q ********************************************************************** 

C * 

C "FFT2D" PERFORMS BOTH A FORWARD OR INVERSE FAST FOURIER * 

C TRANSFORM. "FFT2D" IS THE DRIVER THAT PASSES THE CORRECT VECTORS * 
C TO "FORK" WHICH PERFORMS THE ACTUAL TRANSFORMING. * 

C THE DIMENSIONING OF "H" MUST BE THE SAME AS IN THE MAIN PROGRAM * 

C * 

C "NSIGN" - DIRECTION OF DESIRED TRANSFORMATION * 

C -+1 INVERSE TRANSFORM (FREQUENCY TO SPATIAL) * 

C —1 FORWARD TRANSFORM (SPATIAL TO FREQUENCY) * 

C * 

Q ********************************************************************** 

C 

COMMON H (512, 512) 

COMMON CTEMP (512) 

COMPLEX H, CTEMP 
C 

SIGNI -FLOAT (NSIGN) 

IF (IABS (NSIGN) .NE.l) THEN 
WRITE (6, 105) 

STOP 

ENDIF 


C 

C OPERATE BY ROWS 

C 

DO 101 IY-1, NY 

101 CALL FORK (NX, H (1, I Y) , SIGNI ) 

C 

C OPERATE BY COLUMNS 

C 

DO 104 IX-1, NX 
DO 102 IY-1, NY 

102 CTEMP (IY)-H (IX, IY) 

CALL FORK (NY, CTEMP, SIGNI) 

DO 103 IY-1, NY 

103 H (IX, IY) -CTEMP (IY) 

104 CONTINUE 


C 

105 

C 


RETURN 

FORMAT (5X, * "NSIGN" MUST EQUAL +1 OR -1 FOR "FFT2D", FATAL') 
END 


£*********************«************************************************* 

C 

SUBROUTINE FORK (LXX, CX, SIGNI ) 

C 

£*********************************************************************** 
C * 

C FAST FOURIER TRANSFORM, MODIFIED FROM CLAERBOUT, J.F., FUNDAMENTAL * 

C OF GEOPHYSICAL DATA PROCESSING, MCGRAW-HILL, 1976 * 

C FORK USES COOLEY-TUKEY ALGORITHM. 

C * 

C "CX" - DATA VECTOR TO BE TRANSFORMED * 

C "LXX" - LENGTH OF DATA VECTOR "CX" TO BE TRANSFORMED, * 

C MUST BE A POWER OF 2 (LXX-2 ** INTEGER) * 

C "SIGNI"- DIRECTION OF DESIRED TRANSFORMATION * 

C -+1. INVERSE TRANSFORM (FREQUENCY TO SPATIAL) * 

C —1. FORWARD TRANSFORM (SPATIAL TO FREQUENCY) * 

C * 

C NORMALIZATION PERFORMED BY DIVIDING BY * 

C DATA LENGTH UPON THE FORWARD TRANSFORM. * 

C* ************************* ********************************************* 
C 

COMPLEX CX (LXX), CW, CTEMP, CON2 
C 


LX -LXX 

LXH-LX/2 

J-l 

DO 103 I— 1, LX 

IF (I.LT.J) THEN 
CTEMP-CX (J) 
CX(J)-CX(I) 

CX (I) -CTEMP 
ENDIF 
M-LXH 
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102 IF (J.GT.M) THEN 

J-J-M 

M-M/2 

IF (M.GE.l) GO TO 102 
ENDIF 
J-J+M 

103 CONTINUE 
L-l 

104 ISTEP-2*L 

CON2- (0.0, 3. 14159265) /FLOAT (L)*SIGNI 
DO 105 M-1,L 

CW-CEXP (CON2 *FLOAT (M-l ) ) 

DO 105 I-M, LX, I STEP 
CTEMP-CW*CX (I + L) 

CX (I + L) -CX (I)— CTEMP 

105 CX (I ) — CX (I ) + CTEMP 
L^i STEP 

IF (L.LT.LX) GO TO 104 
IF (SIGNI.GT. 0.0) RETURN 
SC-1. /FLOAT (LX) 

C 

DO 106 I - 1 , LX 

106 CX(I)-CX(I)*SC 
C 

RETURN 

END 

C 

£***★**********+**********★***********************+****+***************+ 

c 

SUBROUTINE DATWND (PRCNT, NX1 1 , NYll , NX, NY, fold, itypefold) 

C 

C*********************************************************************** 

C * 

C "DATWND" MULTIPLIES THE INPUT F(1,X,Y) BY A HALF BELL OF A HANMIN- * 

C TUKEY WINDOW ON ALL EDGES AND ZEROS OUT THE REMAINDER OF THE * 

C (NX, NY) ARRAY. * 

C * 

C "PRC NT" -PERCENTAGE OF DATA TO BE ALTERED IN SMOOTHING TO ZERO * 

C 0.0 .LT. "PRCNT" .LE. 50.0 * 

C 

c update 2 feb 91 

c datwnd has been considerably improved such that now the subroutine 
c performs three (count them, three !!) functions. one; a percentage 
c of the input matrix can be folded out. two; after folding out, 

c a new percentage of the folded out matrix (or regular data if 

c folding was not performed) can be smoothed to zero, three; the 

c manipulated data is centered within zeros to finish filling the 

c matrix to nx by ny size, because the actual data is now centered 

c within the transformed array, it is necessary to use the 

c do loops in subroutine inverseft to correctly extract the actual 
c data 
c 

C*********************************************************************** 

C 

dimension holdme (512, 512 ) 

COMMON F (2, 512, 512) 

C 

nxl-nxll 

nyl-nyll 

C 

c fold out the data based on percentage 

c 

If (fold. gt. 0.0 .and. fold.lt. 100.0) then 
c 

KX-Int (fold* FLOAT (NX1 ) /100.0+0. 5) 

KY-Int (fold*FLOAT (NYl ) /100. 0+0. 5) 
if (kx+nxl .gt. nx) kx- (nx-nxl ) /2 
if (ky+nyl .gt. ny) ky- (ny-nyl ) /2 
do j-l,nyl 
do i-1 , nxl 

holdme (i, j)-f <l,i, j) 
enddo 
enddo 


c fold out the columns in each row: 

c if itypefold is 1 then the data is considered to 

c to be a rectangular style of projection where 

c the east and west edges of the data are not 

c covering the same geographic region, therefore, 

c the folding out of data along a row is symetric 

c with respect to the individual edge, 

c 


if (itypefold ,eq. 1 } then 
do j-l,nyl 

do i-1, nxl+kx+kx 

if (i.le.kx) f (1,1, j> -holdme (kx-i+1, j) 

if (i.gt.kx .and. i . le . (kx+nxl) ) f (1, i, j) -holdme (i-kx, j) 
if (i .gt . (kx+nxl) ) f (1 , i, j) -holdme ( (2*nxl+kx+l-i ), j) 
enddo 
enddo 
c 
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c if itypefold is 0 then the array is considered to 

c be a polar style of projection where the east and 

c west edges are covering the same geographic area, 

c therefore, the folding along each row is actually 

c adding the western edge of data to the eastern 

c edge and eastern data to western edge, 

c 


elseif (itypefold .eq. 0) then 
do j-l,nyl 

do i-1, nxl+kx+kx 

if (i.le.kx) f <1,1, j)-holckne(nxl+i-kx, j) 
if (i.gt.kx .and. i. le. (kx+nxl) ) f (1, i, j) -holdme (i-kx, j) 
if (i.gt . (kx+nxl) ) f (1 f i, j) -holdme ( (i-nxl-kx) , j) 
enddo 
enddo 
endif 
c 

if (nyl .eq. 1) go to 333 
do j-1 , nyl 

do i-1, nxl+kx+kx 

holdme (i,j)-f(l,i, j) 
enddo 
enddo 

c fold out the rows in each column 

do i-1, nxl+kx+kx 
do j-1, nyl+ky+ky 

if (j.le.ky) f (1, i, j) -holdme (i, ky-j+1 ) 

if (j.gt.ky .and. j . le . (ky+nyl ) ) f (1, i, j) -holdme (i, j-ky) 
if (j.gt. (ky+nyl) ) f (1 , i, j} -holdme (i, (2*nyl+ky+l- j) ) 
enddo 
enddo 

nyl-nyll+2*ky 
333 nxl-nxl l+2*kx 
endif 
c 

if (prcnt .gt .0.0 .and. prcnt .It . 50 .0) then 
KX-IFIX (PRCNT* FLOAT (NX1 ) /100 . 0+0. 5) 

KY-IFIX (PRCNT* FLOAT (NYl ) /100 . 0+0. 5) 

C 

C APPLY WINDOW TO COLUMNS 

C 

IF (NYl .NE. 1 .AND. KY.NE.0) THEN 
RKYPI- 3. 14159265/FLOAT (KY) 

DO 10 IY-1 , KY 

FACTOR-0 . 5* (1 . 0+COS (FLOAT (KY-IY+1 > *RKYPI ) ) 

IYY-NY1-IY+1 
DO 10 IX-1 , NXl 

F (1, IX, I Y) - F (1, IX, IY) * FACTOR 
10 F ( 1 , IX, I YY ) - F (1 , IX, IYY) * FACTOR 

ENDIF 

APPLY WINDOW TO ROWS 

IF (KX.NE. 0) THEN 

RKXPI- 3 . 1 4 159265/FLOAT (KX) 

DO 30 IX-1, KX 

FACTOR-0.5* (1. 0+COS (FLOAT (KX-IX + 1 ) *RKXPI) } 

IXX-NXl— IX+1 
DO 30 IY-1 , NY1 

F(1,IX, IY)-F(1,IX,IY) * FACTOR 
F ( 1 , IXX, IY } -F(1,IXX, IY)* FACTOR 

ENDIF 

WRITE (25, 150) KX, KY 
write (25,*) kx,ky 
endif 

center and ZERO OUT REMAINDER OF ARRAY 

nxhalf- (nx-nxl) /2 
nyhalf- (ny-nyl) /2 
do i-1 , nxl 
do j-1, nyl 

holdme (i, j)-f (1, i, j) 
enddo 
enddo 

do i-1, nxhalf 
do j-l,ny 

f (1,1, j)«0.0 
enddo 
enddo 

do i-nxhalf+1, nxhalf +nxl 
do j-l,ny 

if (j .le. nyhalf) f(l,i,j)-0.0 
if (j.gt. nyhalf .and. j. le. nyhalf +nyl) 

*■ f (1, i, j) -holdme (i-nxhalf, j-nyhalf ) 

if (j .gt. nyhalf +nyl ) f(l,i,j)-0.0 
enddo 
enddo 

do i-nxhalf +nxl+l, nx 
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do j-1, ny 

f <l,i, j)-0.0 
enddo 
enddo 
c 

RETURN 

C 

150 FORMAT ( 1 smoothed* , 14, ' values on both x edges'/, 

> • ',14,' y ') 

160 FORMAT (1H-, ' "PRCNT"- ',F7.3, ' OUTSIDE OF PROPER RANGE', 

> ' NO WINDOWING PERFORMED: "DATWND" ' /) 

C 

END 

c 

c 

c 

subroutine filter (num) 

integer num, npass, imean, nwind, nxout, nyout, 

> row, col 

real prcnt, xlag, delta, cuthi, cutlo 
complex xcdata (512, 512) ,ycdata (512, 512) 
common /fftifft/ nxout, nyout, prcnt , imean, fold, itypef old 
common /comps/ xcdata, ycdata 

common /lhbflt/ delta, cuthi, cutlo, xlag, npass, nwind 
COMMON H (512, 512) 

COMPLEX H 
c 

if (num ,eq. 1) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 

elseif (num .eq. 2) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 
endif 

Q ********************************************************************** 


C 

c PROGRAM BANDPASS 

C 

C PROGRAM BANDPASS PERFORMS HIGH, LOW, OR BANDPASS WAVENUMBER 

C FILTERING OF UNIFORMLY GRIDDED ARRAYS. INPUT MATRIX IS THE 

C WAVENUMBER DOMAIN TRANSFORM AS OUTPUT BY SPA2FRQ. AN IDEAL FILTER 

C IS CONSTUCTED IN THE WAVENUMBER DOMAIN, WINDOWED IN THE SPACE 

C DOMAIN, THEN TRANSFORMED BACK INTO THE WAVENUMBER DOMAIN TO BE 

C MULTIPLIED BY THE INPUT TRANSFORM. 

C 

C REQUIRED SUBROUTINES : 

C 

C BNDPAS, FFT2D, FORK, STORE, WINDOW 

C 

C DIMENSIONING REQUIREMENTS : 

C 

C H (N, N ) WHERE N IS THE NUMBER OF COLUMNS AND ROWS OF THE 

C INPUT AND OUTPUT TRANSFORMED MATRIX. N MUST BE AN 

C INTEGRAL POWER OF TWO (2,4,8,16...). 

C NOTE : DIMENSIONS IN EVERY SUBROUTINE MUST BE 

C SET EQUAL TO DIMENSIONS IN MAIN PROGRAM. 

C 

C AUTHOR ; JON REED, PURDUE UNIVERSITY, DECEMBER 1980. 

C REVISIONS BY STEVE MATESKON AND JEFF LUCIUS, 

C OHIO STATE UNIVERSITY, JULY 1984. 

C 

c 

c this program, like others in the fft series, has been updated 

c to the DEC workstation system and now the program is actually 

c usable to just about anybody! revised 21 apr 90 

c 

c well, like the other programs In this package, this has been 
c updated on 4 AUG 90. few comments have been removed - mainly 

c those comments about i/o operations not necessary to this 

c package have been removed, 
c 

c update: 2 feb 90, removed need for cstore array 




CREATE FILTER AND STORE IN ARRAY H 

CALL BNDPAS (CUTLO, CUTHI, NPASS, DELTA, NX, NY ) 
CALL STORE (NX, NY) 

C 

C CREATE SMOOTHED FILTER 

C 

IF (XLAG. GT. 0.0 .AND. XLAG . LE. 1 00 . 0 ) THEN 
IF (NWIND. GT.0. AND. NWIND. LE. 4) THEN 
CALL FFT2D (NX,NY,1) 
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CALL WINDOW (NX, NY, X LAG, WIND) 

CALL FFT2D (NX,NY,-1) 

ENDIF 

ENDIF 

C 

C WRITE FILTER (WAVENUMBER DOMAIN) ONTO UNIT 30 IF IOFIL - 1 

C 

c IF (IOFIL. EQ.l) THEN 

c WRITE (30,*) NX, NY, IZERO, XMEAN 

c DO 200 IY-1,NY 

c WRITE (30, *> <H(IX,IY),IX-1,NX> 

C200 CONTINUE 

c WRITE (6, 1040) NX, NY 

C ENDIF 


C 

if (num .eq. 1) then 
do 500 i-l,row 
do 500 j-l,col 

xcdata(j,i) - xcdata ( j,i) *h ( j, i) 

500 continue 

elseif (num .eq. 2) then 
do 580 i-1 , row 
do 580 j-l,col 

yccLata ( j, i) - ycdata ( j, i) *h ( j, i) 

580 continue 

endif 

return 
end 

*****★**** + ***************■<»*********★*****★*★******★************♦★* + ** 


SUBROUTINE BNDPAS (CCUTLO, CCUTHI , NPASS, DELTA, NX, NY) 
********************************************************************** 


••BNDPAS" CALCULATES TWO QUADRANTS OF THE WAVE# RESPONSE OF 
AN IDEAL BANDPASS FILTER OF A (NX, NY) MATRIX. 

ARRAY "H" MUST BE DIMENSIONED THE SAME AS IN THE MAIN PROGRAM 


"CCUTLO" 

"CCUTHI" 

"NPASS" 


"DELTA" 

"NX" 

"NY" 


LOWEST WAVE# TO BE PASSED, GE 0.0 
HIGHEST WAVE# TO BE PASSED, LE NYQUIST 
SWITCHES EITHER A PASS OR REJECTION BETWEEN 
"CUTLO" & "CUTHI" 

— 1 REJECT WAVENUMBERS BETWEEN THE 2 WAVENUMBERS 

- 1 PASS WAVENUMBERS BETWEEN THE 2 WAVENUMBERS 
DATA GRID INTERVAL, IN MAP UNITS 
NUMBER OF ROWS (POWER OF 2 GE "ICOL", 16, 32, ETC) 
NUMBER OF ROWS (POWER OF 2 GE "IROW", 16, 32, ETC) 


****** ******** ***************************** **************************** 


C 


c 

c 


c 


c 


c 


COMMON H (512, 512) 

COMPLEX H, 2ERO, ONE 
DIMENSION A(2) 

DATA A/4HPASS, 4HCUT / 

CUTHI “CCUTHI 
CUTLO -CCUTLO 
RCUTLO- 99999 9 . 99 

IF (CUTLO. GE. 0.0000001 ) RCUTLO- 1.0/CUTLO 
RCUTHI-1 . 0 /CUTHI 
WAVLEN-2 . 0* DELTA 
FNQl-1 . 0/WAVLEN 

WRITE (25,112) FNQ1,WAVLEN, CUTLO, RCUTLO, CUTHI, RCUTH I, NPASS 

IF (IABS (NPASS) .NE.l) THEN 
WRITE (6, 151) 

STOP 

ENDIF 

I F (CUTHI . GT . FNQ1 . OR. CUTHI . LE . CUTLO . OR . CUTLO . LT . 0 . 0 ) THEN 
WRITE (6, 151) 

STOP 

ENDIF 

NXX-NX+2 
NX2- (NX/2 ) +1 
NY 2- (NY/2 ) +1 
ANY2 -FLOAT (NY 2) 

ZERO - (0. 0,0.0) 

ONE - (1. 0,0.0) 

WAY - A(l) 

IF (NPASS. NE.l) THEN 
ZERO - (1.0, 0.0) 

ONE - (0.0, 0.0} 

WAY - A (2) 

ENDIF 

RHIY2 - (FNQ1/ (ANY2*CUTHI) ) **2 
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NHIY - CUTHI *WAVLEN*ANY2+1 .0 
NHIY -AM I NO {NHIY, NY2) 

CLOWX- FLOAT (NX 2) *WAVLEN*CUTLO 
CHIX -FLOAT (NX2)*WAVLEN*CUTHI 
C 

IF (CUTLO.LE. 0.000001) THEN 
c WRITE (6,152) WAY 

RLOWY2-0 . 0 
NLOWY-O 
ELSE 

IF (FNQl -CUTHI. LT. 0.00001) THEN 
c WRITE (6, 153) WAY 

RL0WY2- (FNQl/ (ANY2*CUTLO) )**2 
NLOWY-CUTLO*WAVLEN*ANY2+l . 0 
ELSE 

c WRITE (6, 154) 

RLOWY2- (FNQl/ (ANY2 *CUTLO ) ) * *2 
NLCWY -CUTLO*WAVLEN*ANY2+l . 0 
ENDIF 
ENDIF 


’’ZERO" OUT THE PART OF ARRAY TO BE ALTERED 

DO 35 IY-1 , NY2 
DO 35 IX— 1 , NX 
H (IX, I Y) - ZERO 
5 CONTINUE 

OPERATE ON ROWS WHERE SOME WAVENUMBERS ARE .LE. CUTLO 

IF (NLOWY.NE.0) THEN 
MINS-1 
MAX S -NX 2 

IF (NLOWY.EQ. 1) THEN 

IF (CUTLO. GT. 0.00001) MINS-NX2*CUTLO*WAVLEN+2.0001 
IF (FNQ1-CUTHI.GT. 0.00001) MAX S-NX2* CUTHI *WAVLEN+1 .0001 
ENDIF 

DO 102 I Y-l , NLOWY 
Y2-FLOAT (I Y-l ) * *2 
MINX -MINS 

IF (CUTLO. GT. 0.000001) THEN 

MI NX-C LOWX * SQRT ( 1 . 0-Y2 * RLOWY 2 } + 2 . 0 00 1 
ENDIF 
MAX X -MAX S 

IF (FNQ1-CUTHI .GE . 0.00001 ) THEN 

MAXX-CHIX* SQRT (1 , 0— Y2*RHIY2 ) +1 . 0001 
ENDIF 

IF (MINX . EQ. 1 ) THEN 
H (1, IY) - ONE 
MINX-MINX+1 
ENDIF 

IF (MINX.LE.MAXX) THEN 
DO 150 I X-MI NX , MAXX 
H (NXX-IX, IY ) - ONE 
150 H (IX, IY) - ONE 

ENDIF 

102 CONTINUE 
ENDIF 

.....OPERATE ON ROWS WHERE ALL WAVENUMBERS ARE .GT. CUTLO 

IF (NHIY.NE.NY2) THEN 
LL-NLOWY+1 
DO 200 I Y-LL, NHIY 
Y2-FLOAT (IY-1 ) **2 

MAXX-CHIX* SQRT (1 . 0-Y2*RHI Y2 ) +1 . 0001 
H (1, IY) - ONE 
IF (MAXX , NE . 1 ) THEN 
DO 180 IX-2,MAXX 

H (NXX-IX, IY)- ONE 
180 H ( IX, I Y) -ONE 

ENDIF 

200 CONTINUE 

ELSE 

IF (NLCWY+1 .GT.NY2) RETURN 
LL-NLOWY+1 
DO 215 IY-LL, NY2 
DO 215 IX-1, NX 
H (IX, IY) - ONE 
215 CONTINUE 

ENDIF 

RETURN 

112 FORMAT (/IX, 'NYQUI ST WAVENUMBER «\F10.5, ’CYCLES PER DATA INTERVAL' 

> /IX, 'NYQUI ST WAVELENGTH - ' ,F10.5, * LENGTH INTERVALS'/ 

> IX, 'LOW WAVE# CUTOFF OF IDEAL FILTER - \F10.5, 

> * CYCLES PER DATA INTERVAL' , 3X, F15 . 5, ' WAVELENGTH EQUIVALENT'/ 

> IX, 'HIGH WAVE# CUTOFF OF IDEAL FILTER - \F10.S, 
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> • CYCLES PER DATA INTERVAL * , 3X, FI 5 . 5, 

> * WAVELENGTH EQUIVALENT' , /IX, 'NP ASS- *,I1//) 

151 FORMAT (5X , ' IMPOSSIBLE FILTER CONSTRUCTION IS SPECIFIED. FATAL') 

152 FORMAT (1H-, ' LOW *,A4,' FILTER IS BEING CONSTRUCTED IN "BNDPAS" ' /) 

153 FORMAT (1H-, 'HIGH \A4, ' FILTER IS BEING CONSTRUCTED IN "BNDPAS" * /) 

154 FORMAT (1H-, * BAND PASS FILTER IS BEING CONSTRUCTED IN "BNDPAS”'/) 

C 

END 

C 

C 

C** a**************************************** **************************** 

c 

SUBROUTINE STORE (NNX, NNY ) 

C 

COMMON H (512,512) 

COMPLEX H 
C 

IF (NNY. EQ. 1) RETURN 
NX-NNX 
NY-NNY 
NX H- NX/2 + 1 
NX X- NX +2 
NYH-NY/2+2 
NYL-NYH-1 
DO 15 IY-NYH, NY 
NYL-NYL-1 
H (1, IY) -H (1, NYL) 

DO 10 IX- 2, NX 

H ( IX, IY ) “CONJG (H (NXX-IX, NYL) ) 

10 CONTINUE 

H (NXH, IY) -H (NXH, NYL) 

15 CONTINUE 
C 

RETURN 

END 

C 

£********★★****★*****★****★*****************★★**********+*★***********+* 


c 


SUBROUTINE WINDOW (NX, NY, XLAG, NWIND } 

C 

£***************★*****************************************★***★★******** 


c 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


"WINDOW" PERFORMS 2 -DIMENSION WINDOWING OVER A 4 QUAD. DATA ARRAY * 
EACH QUAD. IS SEPERATELY WINDOWED. THE 1.0 COEFFICENT IS ALWAYS * 
THE OUTER MOST CORNER OF THE ARRAY. * 

FOR ONE DIMENSIONAL WINDOW, LET NY-1 * 

★ 

"NX" - NUMBER OF COLUMNS IN DATA MATRIX * 

"NY" - NUMBER OF ROWS IN DATA MATRIX * 

"XLAG" - SMOOTHING PARAMETER FOR WINDOWING IDEAL FILTER IN SPATIAL * 

DOMAIN. DETERMINES WHAT PERCENTAGE OF DATA IS WINDOWED * 
(NX*XLAG/100.0) THE REMAINDER IS SET TO 0.0. I.E. THE * 

SMALLER "XLAG" THE SMOOTHER THE WINDOWING. * 

"XLAG" MUST BE .GT. 0.0 .AND. LE. 100.0 FOR WINDOWING * 

VALUES OUTSIDE OF THIS RESULTS IN NO WINDOWING * 

THE SMALLER THE "XLAG" THE SMOOTHER THE FILTER. * 

* 

"NWIND" - TYPE OF WINDOW TO APPLY * 

-0 GIVES NO WINDOW * 

-I gives a rectangular window 

-2 GIVES BARTLETT WINDOW (TRIANGLE WINDOW) * 

-3 GIVES HANMI NG-TUKEY WINDOW * 

-4 GIVES PAR2EN WINDOW * 

* 

A***-****************************************************************** 


COMMON H (512, 512) 
COMPLEX H 


IF (XLAG. LE. 0.0 .OR. XLAG. GT. 100 .0) THEN 
WRITE (6, 50) XLAG 
RETURN 
ENDIF 


C 

LAG-FLOAT (NX) *XLAG/200 .0+0. 5 

LAG-AMAXO (LAG, 2) 

PI-3.14159265 

NX X- NX +2 

NYY-NY+2 

NX 2- (NX/ 2 ) + 1 

XNXR- FLOAT (NX2 ) 

XNX -1.0/ FLOAT (NX2) 

NY 2- (NY/2 ) +1 
IF (NY.EQ.l) NY2-1 
YNY -1.0/ FLOAT (NY2) 

C 


RADIUS-FLOAT (LAG) * XNX 

RADI -1.0/ RAD I US 

RAD2- RADIUS* RADIUS 

NRAD- FLOAT (NY2 ) * RADIUS+1 . 0001 
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C APPLY RECTANGULAR WINDOW TO FILTER 

C 

IF (NWIND.EQ.l) THEN 
C 

IF(NRAD.NE.O) THEN 

MAX-PAD IUS*XNXR+1 .0001 
C 

IF (MAX. EQ. 0) THEN 
H(l,l>-(0. 0,0.0) 

MAX-MAX+1 
END IF 
C 

LL-MAX+1 

DO 155 II-LL,NX2 

H (NXX-II, l)-(0. 0,0.0) 

155 H(II,1)- (0. 0,0.0) 

ENDIF 

C 

IF (NRAD.NE. 1 .AND.NRAD.NE.O) THEN 
DO 102 IY-2 , NRAD 
I YY-NYY-I Y 

YLEN2- (FLOAT(IY-l) *YNY) **2 
MAX-SQRT (RAD2-YLEN2 ) *XNXR+1 . 0001 
C 

IF (MAX . EQ . 0) THEN 
H (1, IY) - (0.0, 0.0) 

H(IY, IYY)- (0.0, 0.0) 

MAX-MAX+1 

ENDIF 

C 

LL-MAX+1 

DO 105 II-LL, NX2 

H (NXX-II f IY)-(0. 0,0.0) 

H (II, IY)-(0. 0,0.0) 

H (NXX-II, IYY) -(0.0, 0.0) 

105 H (II, IYY)- (0.0,0. 0) 

102 CONTINUE 

ENDIF 
C 

c WRITE (25, 660) X LAG, LAG 

IF (NRAD. EQ. NY2 ) RETURN 
LL-NRAD+1 
DO 108 I -LL, NY2 
I YY-NYY-I 
H (1, I)- (0.0, 0.0} 

H(l, IYY)- (0.0, 0.0) 

DO 109 J-2, NX2 
H(J,I)-(0. 0,0.0) 

H (NXX-J, I)- (0.0, 0.0) 

H(J,IYY)-(0. 0,0.0) 


109 H (NXX-J, IYY) - (0.0, 0.0} 

108 CONTINUE 
C 

C APPLY BARTLETT WINDOW TO FILTER 


C 

ELSE IF (NWIND. EQ. 2) THEN 
C 

IF (NRAD.NE. 0) THEN 

MAX-RADIUS*XNXR+1 .0001 
C 

IF (MAX. GE. 2) THEN 
DO 253 LL-2, MAX 

XI -FLOAT (LL-1 ) *XNX 
FACTOR-1. 0-XI* RAD I 
H ( LL, 1 ) -H < LL, 1 ) * F ACTOR 
MX-NXX-LL 

253 H (MX, 1)-H(MX, 1) *FACTOR 

ENDIF 
C 

LL-MAX+1 

DO 255 II-LL, NX2 

H (NXX-II, l)-(0. 0,0.0) 

255 H(II,l)-(0. 0,0.0) 

ENDIF 

C 

IF (NRAD.NE. 1. AND.NRAD.NE.O) THEN 
DO 202 IY-2, NRAD 
IYY-NYY-I Y 
XI -FLOAT (IY— 1) *YNY 
YLEN2- XI*XI 

MAX-SQRT (RAD2-YLEN2 ) *XNXR+1 . 0001 
FACTOR- 1. 0-XI* RADI 
H (1, IYY) -H (1, IYY) * FACTOR 
H (1 , I Y) -H ( 1 , IY) * FACTOR 
C 

IF (MAX. GE. 2) THEN 
DO 203 LL-2, MAX 

XI-SQRT( (FLOAT (LL-1) *XNX) **2+YLEN2) 
FACTOR- 1 .O-XI* RAD I 
H (LL, IYY) -H (LL, IYY) *FACTOR 
H (LL, IY) -H (LL, IY) * FACTOR 
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203 


C 


205 

202 

C 

c 


209 

208 

C 

c. . 
c 

c 


c 


353 


C 


355 


c 


c 


303 


c 


305 

302 


C 

c 


MX-NXX-LL 

H (MX, IYY) -H (MX, IYY ) * FACTOR 
H {MX, IY} -H (MX, IY) * FACTOR 
ENDIF 

LL-MAX+1 

DO 205 II-LL, NX 2 

H (NXX-II, IYY) - {0 .0, 0.0) 

H(II,IYY>-(0. 0,0.0) 

H (NXX-II, IY)-(0. 0,0.0) 

H(II,IY)-{0. 0,0.0) 

CONTINUE 

ENDIF 

WRITE {25, 661) XLAG, LAG 
IF (NRAD. EQ.NY2) RETURN 
LL-NRAD+1 
DO 208 I-LL,NY2 
IYY-NYY-I 
H(l,I)-(0. 0,0.0) 

H(l,IYY)-(0. 0,0.0) 

DO 209 J-2, NX2 

H(J,IYY)-(0. 0,0.0) 

H (NXX-J, IYY)- (0.0, 0.0) 

H(J, I)-(0. 0,0.0) 

H (NXX-J, I ) - (0. 0, 0 . 0) 

CONTINUE 

APPLY HAMMING -TUKEY WINDOW TO FILTER 

ELSEIF (NWIND.EQ. 3) THEN 

IF (NRAD.NE. 0) THEN 
P I RAD I -P I * RADI 
MAX— RADIUS ‘XNXR+1 .0001 

IF (MAX. GE. 2) THEN 
DO 353 LL-2,MAX 

XI -FLOAT (LL-1 ) *XNX 
FACTOR-0.5* (1 . 0+COS {PIRADI *X I ) ) 

H (LL, 1 ) -H (LL, 1 ) *FACTOR 
MX-NXX-LL 

H (MX, 1) -H (MX, 1 ) * FACTOR 
ENDIF 

LL-MAX+1 

DO 355 II-LL, NX2 

H (NXX-II, l)-(0. 0,0.0) 

H (II, 1 ) - (0. 0,0.0) 

ENDIF 

IF (NRAD. NE.l. AND. NRAD. NE.0) THEN 
DO 302 IY-2, NRAD 
XI -FLOAT (IY-1 ) *YNY 
YLEN2- XI*XI 
I YY-NYY-I Y 

MAX-SQRT (RAD2-YLEN2 ) *XNXR+1 . 0001 
FACTOR-O . 5* (1 .0+COS (PIRADI*XI) ) 

H (1, IYY ) -H (1, IYY) *FACTOR 
H (1, IY) -H (1, IY) ‘FACTOR 

IF (MAX.GE. 2) THEN 
DO 303 LL-2 , MAX 

XI-SQRT ( (FLOAT (LL-1 ) *XNX) * *2 + YLEN2) 
FACTOR-O. 5* (1 . 0+COS (PIRADI *XI> ) 

H (LL, IYY) -H (LL, IYY) ‘FACTOR 
H (LL, IY) -H (LL, IY) ‘FACTOR 
MX-NXX-LL 

H (MX, IYY) -H (MX, IYY) ‘FACTOR 
H (MX, IY) -H (MX, IY) ‘FACTOR 
ENDIF 

LL-MAX+1 

DO 305 II-LL, NX2 

H (NXX-II, IYY)- (0.0, 0.0) 

H(II,IYY)-(0. 0,0.0) 

H (NXX-II, IY)-(0. 0,0.0) 

H(II, IY)-(0. 0,0.0) 

CONTINUE 

ENDIF 

WRITE (25,662) XLAG, LAG 
IF (NRAD. EQ.NY2 ) RETURN 
LL-NRAD+1 
DO 308 I-LL, NY2 
IYY-NYY-I 
H{1, 1)-(0. 0,0.0) 

H(l, IYY)-(0. 0,0.0) 

DO 309 J-2, NX2 

H(J,IYY)-{0. 0,0.0) 
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o o o 


309 

308 


C 


c 


4 53 

C 


457 

455 

C 


C 


C 

403 

C 

C 

407 

405 

402 

C 

c 


H(NXX-J, IYY>- (0.0, 0.0) 

H(J,I)-(0. 0,0.0) 

H(NXX-J,I)-(0.0,0.0) 

CONTINUE 

APPLY PAR2EN WINDOW TO FILTER 

ELSEIF (NWIND. EQ. 4 ) THEN 

IF (NRAD . NE. 0) THEN 

MAX-RAD IUS*XNXR+1 . 0001 
N2 RAD-FLOAT (NY2 ) *RADIUS‘0. 5+1 .0001 
MAX2-SQRT (RAD2/4 .0) ‘XNXR+1 . 0001 
FACTOR-1 .0-6.0* ( (XI ‘RADI ) “2— (XI* RADI) “3) 
H(l,l)-H(l,l) * FACTOR 

IF (MAX2.GE.2) THEN 
DO 453 LL-2,MAX2 
XI -FLOAT (LL-1) *XNX 

FACTOR- 1. 0-6.0* ( (XI‘RADI)“2- (XI*RADI)“3) 

H (LL, 1 } -H (LL, 1 ) * FACTOR 
MX-NXX-LL 

H (MX, 1) -H (MX, 1) *FACTOR 
END IF 

KOUNT-MAX 2 + 1 
DO 457 LL-KOUNT , MAX 
XI -FLOAT (LL-1 }*XNX 
FACTOR- 2 . 0* (1.0- (XI*RADI) )**3 
H (LL, 1 ) -H (LL, 1) ‘FACTOR 
MX-NXX-LL 

H (MX , 1 ) -H (MX, 1 ) * FACTOR 
LL-MAX+1 

DO 455 II -LL, NX2 

H(NXX-II,l)-(0. 0,0.0) 

H (II, l)-(0. 0,0.0) 

ENDIF 

IF (NRAD. NE. 1 .AND. NRAD. NE.0) THEN 
DO 402 IY-2, NRAD 
I YY-NYY-I Y 
XI -FLOAT (IY-1 ) *YNY 
YLEN2- XI*XI 

MAX-SQRT (RAD2-YLEN2 ) ‘XNXR+1 . 0001 
N2 RAD -FLOAT (NY 2) *RADIUS*0 . 5+1 . 0001 

IF (IY.GT.N2RAD) THEN 
KOUNT-2 

FACTOR-2 . 0* (1.0- (XI *RADI ) ) **3 
H (1, IYY) -H(l, IYY) ‘FACTOR 
H(1,IY)-H(1,IY) ‘FACTOR 
ELSE 

MAX2-SQRT (RAD2 /4 . 0-YLEN2 ) ‘XNXR+1 .0001 
FACTOR- 1.0- 6.0* ( (XI*RADI ) * *2- (XI *RADI ) ** 3) 

H (1, IYY) -H (1, IYY) * FACTOR 
H (1, IY)-H(1, IY) ‘FACTOR 

IF (MAX2.GE.2) THEN 
DO 403 LL-2, MAX2 

XI-SQRT ( (FLOAT (LL-1) *XNX) “2+YLEN2) 

FACTOR- 1.0- 6.0* ( (XI ‘RADI ) “2- (XI ‘RADI ) “3) 
H (LL, IYY) -H (LL, IYY) ‘FACTOR 
H (LL, IY)-H(LL, IY) ‘FACTOR 
MX-NXX-LL 

H (MX, IYY ) -H (MX, IYY) ‘FACTOR 
H (MX, IY ) -H (MX, IY) ‘FACTOR 
ENDIF 

KOUNT-MAX2+1 

ENDIF 

DO 407 LL-KOUNT, MAX 

XI-SQRT ( (FLOAT (LL-1 ) ‘XNX) “2 +YLEN2 ) 

FACTOR-2 . 0* (1.0- (XI ‘RADI) } “3 
H (LL, I YY) -H (LL, IYY) ‘FACTOR 
H (LL, I Y) -H (LL, I Y ) ‘FACTOR 
MX-NXX-LL 

H (MX, IYY) -H (MX, IYY) ‘FACTOR 
H (MX, IY) -H (MX, IY) ‘FACTOR 
LL-MAX+1 

DO 405 II-LL, NX2 

H (NXX-II , IYY) - (0 . 0, 0 . 0) 

H (II, IYY)-(0. 0,0.0) 

H (NXX-II, IY)-(0. 0,0.0) 

H(II, IY)-(0. 0,0.0) 

CONTINUE 

ENDIF 

WRITE (25, 663) X LAG, LAG 
IF (NRAD. EQ. NY2 ) RETURN 
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LL-NRAD+1 
DO 408 I-LL,NY2 
IYY-NYY-I 
H (1 , 1) - (0 .0, 0. 0) 

H(l,IYY)-(0. 0,0.0) 

DO 409 J-2,NX2 

H ( J, I YY) - (0. 0, 0. 0) 

H (NXX-J, IYY)-<0.0,0.0) 

H(J,I>-(0. 0,0.0) 

409 H (NXX-J, I)-(0. 0,0.0) 

408 CONTINUE 
C 

C DO NOT APPLY A WINDOW TO FILTER 

C 

ELSEIF (NWIND. EQ. 0} THEN 
c WRITE (25, €64) 

ENDIF 

C 

RETURN 

C 

50 FORMAT (3X, ' INPUTTED XLAG OF *,F5.2,' EXCEEDS PERMISSIBLE 

> 'RANGE OF.GT. 0.0 .AND. .LE. 100.0, NO WINDOWING PERFORMED') 

660 FORMAT (' RECTANGULAR WINDOW USED XLAG- ' , F7 . 3, 4X, ' LAG- ',15) 

661 FORMAT ('BARTLETT WINDOW USED XLAG- ‘ , F7 . 3, 4X, ' LAG- \I5) 

662 FORMAT (' HAMMING- TUKEY WINDOW USED XLAG- ' , F7 . 3, 4X, ' LAG- ’,15) 

663 FORMAT (' PAR2EN WINDOW USED XLAG- * , F7 . 3, 4X, ' LAG- ',15) 

664 FORMAT ('NO WINDOWING HAS BEEN APPLIED ; XLAG- *,F7.3) 

C 

END 

C 

c 

subroutine correlate (xpassno, ypassno) 
integer xrow,xcol,yrow,ycol, nxout, nyout, 

> xpassno, ypassno, zerocnt (512, 512 ) , cnwind 
real mince, maxcc, ccwinout,prcnt, 

> pctpr3,pctpr4,minccin,maxccin, cxlag 
complex h (512, 512 ) , power5, power6, totpwr 
COMPLEX X(512,512),Y(512,512), zero, 

> POWER1 , POWER2 , POWER3 , POWER4 , XPOWER, TPOWER 
REAL CCOEF , CCIN, CCOUT 

DATA ZERO/ (0.000000,0.000000)/ 
common /rowcol/ xrow, xcol, yrow, ycol 
common /comps/ x,y 

common /ccflt/ mince, maxcc, minccin, maxccin, cnwind, cxlag 
ccmmon /fftifft/ nxout, nyout , prent, imean, fold, itypefold 
common h 


c 

c subroutine description 

c 

c correlate finds the correlation coefficient between each 

c wavenumber component of the two input arrays, each cc is 

c normalized to range between -1.0 through 0.0 to 1.0. the 
c cc is the cosine of the phase angle difference between 

c two wavenumber components, 

c 

c revised 4 aug 90: i've added the windowing functions 

c available from the bandpassing subroutines to this cc- 

c filter. try them if you like, 

c 

c updates 1 feb 91: change calculation of correlation 

c coefficient from a summation based formula to the cosine of 
c the phase angle difference. 


c 

c 

nx-nxout 

ny-nyout 

c 

if (xcol ,ne. ycol .or. xrow .ne. yrow ) then 
write (*,*) 'NO MATCH BETWEEN RCW OR COLUMN' 
write (*,*) 'CORRELATION COEF MAY NOT BE CORRECT' 
write (*,*) ' PASSNUMBERS- 1 , xpassno, ypassno 

write (*,*) 'FILE 1: ROW COL xrow, xcol 

write (*,*) 'FILE 2: ROW COL yrow, ycol 

endif 
c 

pi-3.141592654 
twopi-6. 283185307 
POWER! -ZERO 
POWER2-ZERO 
POWER3-ZERO 
POWER4-ZERO 
XPOWER-ZERO 
TPOWER- ZERO 
C 

DO 110 j-1 , NY 
DO 120 1-1, NX 

c 
c 
c 


zerocnt array is a flagging array used to 
set the windowing array h to equal 
(0.0, 0.0) or (1. 0,0.0). a little inspection 
of subroutine BNDPAS will help illuminate 
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c the principle. 

zerocnt (i, j) -1 

c 

C SUM THE POWERS t CROSS PRODUCTS OF THE INPUT MAPS. 

C 

POWERl-PCWERl* (X (I, J) *CONJG (X (I, J) } ) 

POWER2-POWER2+ (Y (I, J) *CONJG (Y (I, J) ) ) 

XP OWE R-X POWER* (X {I, J) *CONJG (Y (I , J) ) ) 

C 

c xrad is the phase angle of the x array wavenumber and 

c yrad is the phase angle of the y array wavenumber, the 

c cosine of the minimum phase difference is the correlation 

c of the two wavenumbers, to find the minimum phase difference 

c it is necessary to adjust xrad or yrad with integer values 

c of pi. so. ...do not change the order of the if statements I! 

c 

xrad-atan (aimag(x (i, j) ) / (real (x (i, j) ) ) ) 
if (real (x(i, j) ) .It. 0.0) xrad-xrad+pi 
if (aimag (x (i, j) ) .It .0.0} xrad-xrad+twopi 
yrad-atan (aimag (y (i, j) }/(real (y (i, j) ) ) ) 
if (real (y (i, j)) .It. 0.0) yrad-yrad+pi 
if (aimag (y (i, j) ) .It .0.0) yrad-yrad+twopi 
delrad-abs (xrad-yrad) 
ccoef-cos (delrad) 
c 

IF (CCOEF .GT. maxcc .or. CCOEF .LT. mince) THEN 
X (I, J) -ZERO 
Y (I, J)-ZERO 
zerocnt (i, j) -0 
ENDIF 
c 

C SUM THE POWERS & CROSS PRODUCTS FOR THE OUTPUT MAPS. 

C 

POWER3-PCWER3+ (X (I, J) *CONJG (X (I, J) ) ) 

POWER4 -PCWER4 * (Y (I, J) *C0NJG (Y (I, J) ) ) 

TP OWE R-T POWER* (X ( I , J) *CON JG { Y { I # J) ) ) 

120 CONTINUE 
110 CONTINUE 
C 

C CALCULATE THE C.C. FOR THE INPUT MAPS. 

C 

if (powerl .eq. zero .or. power2 .eq. zero) then 
write (*,*) 'powerl powerl, xpassno 

write (*,*) 'power2 , power2, ypassno 

ccin-9999.9 
else 

CC IN-REAL (XPOWER/ SQRT (P0WER1 *P0WER2 ) ) 
endif 
C 

C CALCULATE THE C.C. FOR THE OUTPUT MAPS. 

C 

if (power3 .eq. zero .or. power4 .eq. zero) then 
write (*,*) *power3 power3, xpassno 

write (*,*) *power4 , power 4, ypassno 

ccout-9999. 9 
else 

CCOUT-REAL (TPOWER/SQRT (POWER3* POWER4 ) ) 
endif 
C 

C CALCULATE THE PERCENTAGE OF THE POWER RETAINED IN THE FILTERED 
C MAPS. 

C 

if (powerl .eq. zero .or. power 2 .eq. zero) then 
petpr 1-9999. 9 
pctpr2-9999. 9 
else 

PCTPRl- (POWER3/PCWER1 ) *100.0 
PCTPR2- (POWER4/PCWER2) *100.0 
endif 
C 

C WRITE THE C.C. FOR THE INPUT i OUTPUT MAPS TO FILE 6. 

C 

c WRITE (6, 444 ) CCIN 

c WRITE (6,555) CCOUT 

C 

C WRITE THE POWER PERCENTAGES TO FILE 6. 

C 

C WRITE (6,666) PCTPRl , PCTPR2 

C 444 FORMAT (' ' , * THE CORRELATION COEFFICIENT BETWEEN THE INPUT ' 
c * , 'MAPS IS • ,F6.3) 

C 555 FORMAT (' ' , ' THE CORRELATION COEFFICIENT BETWEEN THE OUTPUT ' 
c * , 'MAPS IS ' ,F6.3) 

C 666 FORMAT (' 1 , 1 THE PERCENTAGE OF THE TOTAL POWER IN MAP ONE', 

C ** PASSED IS', F7. 3, ' THE PERCENTAGE OF THE TOTAL POWER', 

c *' IN MAP TWO PASSED I S' , F7 . 3, ’ % ' ) 

C 

c 

write (25,088) xpassno, ypassno, ccin, ccout,pctprl , pctpr2 
088 format <2i6,4fl0.3) 

if (ccin .it. minccin) write (*,*} xpassno, ypassno, ccin, ' <min‘ 
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if (ccin .gt. maxccin) write (*, * ) xpassno, ypassno, ccin, ' >max' 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 9970 

c 

c 


the following if statement controls 

the windowing functions for smoothing 

the output arrays and calculates a new 

output correlation coefficient and 

percents of power retained in the 

windowed arrays because 

the data will change slightly with 

windowing 


write (*,*) '1 - zerocnt, 0 !« zerocnt* 
read (*,*) i 
if (i .eq. 1) then 
write (50,*) nx 
write (50,*) ny 
do i-l,ny 

write (50, 9970) (zerocnt ( j, i) , j-1 , nx) 
enddo 

format (20 (13, lx)) 
endif 


if (cnwind .ge. 1 .and. cnwind .le. 4) then 
power5-zero 
power6-zero 
totpwr-zero 
do 300 i-l,ny 
do 300 j-l,nx 

h(j,i>- (1.0, 0.0) 

if (zerocnt (j, i) .eq. 0) h(j,i) - (0.0, 0.0) 
300 continue 

call store (nx,ny) 
call fft2d (nx,ny, 1) 
call window (nx, ny, cxlag, cnwind) 
call fft2d (nx,ny,-l) 
do 330 iy-l,ny 
do 330 ix-l,nx 

x(ix, iy) - x (ix, iy) *h (ix, iy) 
y (lx, iy ) - y (ix, iy ) *h (ix, iy ) 
power 5-power 5+ (x (ix, iy ) *con jg (x (ix, iy) ) ) 
power 6-power 6+ (y (ix, iy) *con jg(y (ix,iy) } ) 
totpwr-totpwr* (x (ix, iy) *con jg(y (ix, iy) ) ) 

330 continue 

if (powers .eq. zero .or. power6 .eq. zero) then 
write (*,*) 'power5 -*, powerS, xpassno 
write (*,*) 'power6 - ' , power6, ypassno 
ccwinout-9999. 9 
go to 340 
endif 

if (powerl .eq. zero .or. power2 .eq. zero) then 
pctpr3-9999. 9 
pctpr4-9999. 9 
go to 340 
endif 


ccwinout-real (totpwr/sqrt (power5*power6) ) 
pctpr3-(power5/powerl) *100. 0 
pctpr4- (power6/power2) *100. 0 
340 continue 

write (25,888) xpassno, ypassno, ccin, ccwinout, pctpr3, pctpr4 
c 888 format (216, 4f 10. 3) 
endif 


return 

end 


subroutine inverseft (num,mean, passno) 
integer num, xrow, xcol, yrow,ycol, row, col, passno 
real xdata (361, 361) , ydata (361, 361 ) ,mean 
complex xcdata (512, 512) ,ycdata (512,512) 
common /rowcol/ xrow, xcol, y row, ycol 
common /reals/ xdata, ydata 
common /comps/ xcdata, ycdata 

common /fftifft/ nxout, nyout, prcnt , imean, fold, ityoefold 
COMMON H (512, 512 ) 

DIMENSION X (2, 512, 512) , holdme (361, 361) 

COMPLEX H 

EQUIVALENCE (X (1 , 1, 1 ) , H (1 , 1 ) ) 

if (num .eq. 1) then 
ny-nyout 
nx-nxout 


row-xrow 
col -xcol 
do 50 j-l,ny 
do 50 1-1, nx 

h (i, j) - xcdata (i, j) 
50 continue 

elseif (num .eq. 2) then 
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ny-nyout 
nx-nxout 
row-yrow 
col-ycol 
do 80 1-1 f ny 
do 80 i-l,nx 

h (i, j) - ycdata (i, j) 
80 continue 

endif 




PROGRAM FRQ2SPA 

PROGRAM FRQ2SPA INVERSE TRANSFORMS AN N X N MATRIX OF WAVENUMBER 
DOMAIN COEFFICIENTS INTO THE N X N MATRIX OF SPACE DOMAIN 
AMPLITUDES. FUNCTIONS PERFORMED BY THIS PROGRAM INCLUDE : 

- INVERSE TRANSFORM OF THE DATA 

- RESTORING THE MEAN TO THE DATA 

- CALCULATION OF SPACE DOMAIN MAXIMUM AND MINIMUM AMPLITUDES 
REQUIRED SUBROUTINES : 

FFT2D, FORK 

DIMENSIONING REQUIREMENTS : 

X (2,N,N) WHERE N IS THE NUMBER OF COLUMNS AND ROWS OF THE 

H (N, N) OUTPUT TRANSFORMED MATRIX. N MUST BE AN INTEGRAL 

POWER OF TWO {2, 4, 8, 256. . . ) . 

NOTE : DIMENSIONS IN EVERY SUBROUTINE MUST BE 
SET EQUAL TO DIMENSIONS IN MAIN PROGRAM. 


AUTHOR : JEFF LUCIUS 

DEPARTMENT OF GEOLOGY AND MINERALOGY 
OHIO STATE UNIVERSITY, DECEMBER 1984. 


revised: 8 AUG 90 
updated: 2 feb 91 

added do loops that find the data portion of the 
zero centered inverse transformed data, a look at 
subroutine datwnd will help figure this out. 




*********************** 


INVERSE TRANSFORM DATA TO THE SPACE DOMAIN 
c 

i row -row 

i col-col 
c 

CALL FFT2D <NX,NY,+1) 

C 

nxhalf- (nx-icol)/2 
nyhalf- (ny-irow) /2 
do i-nxhalf+1 , nxhalf+icol 
do j-nyhalf+l , nyhalf+irow 

holdme (i-nxhalf, j-nyhalf )«x (1,1, j) 
enddo 
enddo 
c 

total-0.0 
DO 210 J-l , I row 
DO 210 1—1,1 col 

x (1, 1, j) -holdme (1, j) 

total -tot al+x (l,i, J) 

210 CONTINUE 

xmean-total/f loat (icol*irow) 

IF (IMEAN ,EQ. 1) THEN 
do 215 j-l,irow 
do 215 i-l,icol 

x(l,i,j)-x(l,l, j)+mean 
215 continue 
ENDIF 
C 

XMIN- 1.0E20 
XMAX— 1.0E20 
DO 220 J-l, i row 

if (num .eq. 1) then 
do 1—1 , icol 

xdata (i, j) - x ( 1 , i , j) 
enddo 

elseif (num .eq. 2) then 
do i-l,icol 

ydata (i, j) - x{l,i, j) 
enddo 
endif 

DO 220 I— 1 , I col 

XMIN-AMIN1 (XMIN, X (1 , I, J) ) 
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XMAX-AMAX1 (XMAX,X (1, I, J) ) 

IF (XMAX.EQ.XU, I, J) ) THEN 
IMAX-I 
JMAX-J 
ENDIF 

IF (XMIN.EQ.X (1, 1, J) ) THEN 
IMIN-I 
JMIN-J 
ENDIF 

220 CONTINUE 

c WRITE (25, 1020) XMAX, }MAX, iMAX, XMIN, jMIN, iMIN, xmean, passno 

write (25,9980) passno, xmean, xmax, jmax, imax, xmin, jmin, imin 
9980 format (15, 2x, f 13. 5, 2x, fl3. 5, 2x, 14, 2x, 14 , fl3 . 5, 2x, 14, 2x,i4) 
C 

1020 FORMAT ('MAXIMUM OF I FFT - 1 , E15. 7, 1 AT ( 1 , 13, ' , ' , 13, ' ) ' /, 

> ‘MINIMUM- ' , E15.7, * AT ( * , 13, ' , • , 13, » ) '/, 

> ‘MEAN AFTER I FFT - *,el5.7,‘ FOR PASS', 16,/) 

C 

return 

END 


subroutine STRKPAS (num) 

integer num, xrow, xcol, yrow,ycol, spass, swind, 

> imean, nxout, nyout, row, col 

real prcnt,slag 

complex xcdata (512, 512) ,ycdata (512,512) 

common /fftifft/ nxout, nyout , prcnt, imean, fold, itype fold 

common /comps/ xcdata, ycdata 

common /striking/ angl , ang2, spass, swind, slag 

COMMON H (512, 512 ) 

COMPLEX H 


c 


C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


if (num „eq. 1) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 

elseif (num .eq. 2) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 
endif 

a********************************************************************* 

★ 

"STRIKE" PERFORMS A STRIKE SENSITIVE FILTERING (FAN FILTER) + 

ON UNIFORMLY GRIDDED ONE OR TWO DIMENSIONAL DATA SETS. * 

* 

"sPASS" - CONTROLS IF DATA IS TO BE PASSED OR REJECTED BETWEEN * 

"ANGl" AND "ANG2". * 

- 1 PASS AZIMUTHS BETWEEN ANGLES "ANG1 " & "ANG2 " * 

— 1 REJECT AZIMUTHS BETWEEN ANGLES "ANGl " & "ANG2" * 

"ANGl" - SMALLEST ANGLE, GE 0.0 .AND. LT "ANG2" 

"ANG2" - LARGEST ANGLE, GT "ANGl" .AND. LE 180.00 


C 

c updates and revisions: 

c 

c 23 dec 91? added this strike pass routine to the fourier 
c program, required removal of write statements 

c 

Q A********************************************************************* 

c 

c 

CALL STRIKE (ANGl , ANG2, sPASS, NX, NY) 

C 

c CREATE SMOOTHED FILTER 

C 

IF (sLAG. gt. 0.0 .and. sLAG.lt .100.0) then 
if (swind. gt.O .and. swind. le. 4) then 
CALL FFT2D (NX,NY,1) 

CALL WINDOW (NX, NY, sLAG, sWIND) 

CALL FFT2D (NX, NY, -1) 
endif 
endif 


C 

c SET UP TO WRITE 30 if desired 

C 

c DO 356 IY-1 , NY 

c WRITE (30) (H (IX, IY) , IX-1 , NX) 

c 356 CONTINUE 
C 

C ACCESS TRANSFORM OF DATA 4 MULTIPLY * FILTER (CONVOLVING) 

C 


if (num .eq. 1) then 
do 500 i-l,row 
do 500 j-l,col 

xcdata(j,i) - xcdata ( j, i ) *h ( j, i ) 
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500 continue 

elseif (num .eq. 2) then 
do 580 i-l,row 
do 580 j-l,col 

ycdata(j,i) - ycdata ( j, i) *h ( j, i) 

580 continue 

endif 
c 

return 

end 

c 

C 

SUBROUTINE STRIKE (AANG1, AANG2, NNPASS, NNX, NNY) 

C 

COMPLEX H, ZERO, ONE 
COM40N H (512,512) 

DATA DG2RAD, DG90 /0. 017453293, 1 .570796327/ 

C 

Q ********************************************************************** 

C "STRIKE" CREATES A STRIKE SENSITIVE FILTER (FAN FILTER) * 

C FOR 2 QUADRANTS OF THE (NX, NY) MATRIX * 

C ARRAY "H" MUST BE DIMENSIONED THE SAME AS IN THE MAIN PROGRAM * 

C * 

C (ANGLES ARE MEASURED IN DEGREES CLOCKWISE FROM NORTH) * 

C "ANG1 " - SMALLEST ANGLE, GE 0.0 .AND. LT ANG2 * 

C "ANG2 " - LARGEST ANGLE, GT ANGl .AND. LE 180.0 * 

C "NPASS" - STATES IF DATA IS PASSED OR REJECTED BETWEEN THE 2 ANGLES * 
C —1 REJECT AZIMUTHS BETWEEN ANGLES "ANGl" 6 "ANG2" * 

C - 1 PASS AZIMUTHS BETWEEN ANGLES "ANGl" « "ANG2" * 

C "NX" - NUMBER OF RCWS (POWER OF 2 GE "NXl", 16, 32, ETC) MAX-128 * 

C "NY" - NUMBER OF RCWS (POWER OF 2 GE "NY1 ", 16, 32, ETC) MAX-128 * 

C * 

C ********************************************************************** 

c 

NX -NNX 
NY-NNY 

ANGl - AANGl 
ANG2 - AANG2 
NPASS - NNPASS 
C 

IF (ANG1.LT.ANG2 .AND. ANGl. GE. 0.0 .AND. ANG2 . LE. 180. 0) GOTO 109 
WRITE (6,125) 

125 FORMAT (5X, 'ILLEGAL SPECIFICATION OF STRIKE ANGLES, FATAL') 

STOP 

109 CONTINUE 
C 

NX2-NX/2+1 

NY2-NY/2+1 

NX1-NX+1 

NXX-NX+2 

NYY-NY+2 

XY- FLOAT (NX 2 ) /FLOAT (NY 2 ) 

C 

ZERO- (0.0, 0.0) 

ONE - (1.0, 0.0) 

IF (NPASS. NE.-l) GOTO 160 
ZERO- (1.0, 0.0) 

ONE - (0.0, 0.0) 

160 CONTINUE 

********************************************************************** 

•ZERO* OUT ARRARY 

********************************************************************** 


DO 15 I Y-l, NY 
DO 15 IX-1, NX 
15 H (IX, IY)-ZERO 

C 

c ********************************************************************** 

C COMPUTE PARAMETERS FOR SOUTHWEST QUADRANT OF MATRIX 

£ ********************************************************************** 

C 

IF (ANG2. GE .90.0) GOTO 20 
IYMAX-0 
GOTO 200 
C 

20 IF (ANGl. GT. 90.0) GOTO 114 
Al-0.0 
TA1-0.0 
IYMAX-NY2 
ADA1-1.5 
GOTO 113 
114 CONTINUE 

Al-ATAN (TAN ( (ANGl -90. 0) *DG2RAD) *XY) 

TA1-TAN (Al) 

IYMAX-FLOAT (NX2 ) /TAl+1 . 0 
IYMAX-AMIN0 (I YMAX, NY2 ) 

ADA1-1.0 
113 CONTINUE 
C 
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IF (ANG2.LT. 180.0) GOTO 115 
A2-DG90 
TA2-0.0 

ADA2 -FLOAT (NX 2 ) +0. 5 
GOTO 116 

115 CONTINUE 

A2-ATAN (TAN ( (ANG2-90.0) *DG2RAD) *XY) 

TA2-TAN (A2) 

ADA 2-1 .0 

116 CONTINUE 
C 

200 IF (ANG1.LE.90.0) GOTO 25 
IYMAXX-0 
GOTO 300 
C 

Q ********************************************************************** 

C COMPUTE PARAMETERS FOR SOUTHEAST QUADRANT OF MATRIX 

Q ********************************************************************** 

C 

25 IF (ANG1.GT.0.0) GOTO 45 
Al-0.0 
TTA1-1.0E20 
ADDAl -FLOAT (NX2 ) -2 . 5 
GOTO 60 

45 IF (ANG1.NE.90.0) GOTO 55 
Al-0.0 
A2-0.0 
TTA1-0.0 
TTA2-0.0 
ADDAl- 0.0 
ADDA2- 0.0 
IYMAXX-NY2 
GOTO 122 

55 Al -ATAN (TAN (ANG1*DG2RAD) /XY) 

TTAl- 1. 0/TAN (Al) 

ADDAl -1.0 
C 

60 IF (ANG2.LT. 90.0) GOTO 121 
IYMAXX-NY2 
TTA2-0.0 
AD DA 2- 0.0 
GOTO 122 

121 CONTINUE 

A2 -ATAN (TAN (ANG2*DG2RAD) /XY) 

TTA2- 1. 0/TAN (A2) 

ADDA2-1.0 

IYMAXX- ABS (FLOAT (NX2 } /TTA2 + 1 . 5) 

I YMAXX-AMI NO ( I YMAXX , NY 2 ) 

122 CONTINUE 
C 

< 2 ********************************************************************** 
C CALCULATE THE FILTER COEFFICENTS 

C ********************************************************************** 

c 

300 NYMAX-AMAXO (I YMAX, IYMAXX) 

DO 50 IY-1, NYMAX 
Y- FLOAT (IY-1 ) 

C 

Q ********************************** 

C DEFINE SOUTHWEST QUADRANT 

Q A********************************* 

C 

IF (IYMAX.LT. I Y) GOTO 30 
MI N- Y * TA1 + ADA1 
MAX-Y*TA2+ADA2 
MAX-AMI NO (MAX , NX 2 ) 

C 

IF (MIN. GT. MAX) GOTO 30 
DO 75 IX-MIN, MAX 
75 H(IX,IY)-ONE 

C 

c ********************************** 

C DEFINE SOUTHEAST QUADRANT 

Q ********************************** 

C 

30 IF (IYMAXX. LT.IY) GOTO 35 

MIN- (NXl- (Y*TTA2) ) +ADDA2 
MIN- AMI NO (MIN, NX) 

MAX- ( NX 1 -( Y * TTAl ))+ ADDAl 
MAX-AMAX0 (MAX, NX 2 + 1 ) 

C 

IF (MAX. GT. NX) GO TO 35 
DO 275 IX-MAX, MIN 
275 H (IX, I Y ) -ONE 

C 

C ***************************************************** 

C USE ANTI -SYMMETRY TO DEFINE QUADRANTS #243 
C ***************************************************** 

C 

35 IF (IY . EQ. 1 .OR. IY.EQ.NY2) GOTO 50 
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IYY-NYY-IY 
DO 40 IX-2,NX 

40 H (NXX-IX, IYY) -H (IX, IY) 

H(1,IYY)-H(1,IY) 

50 CONTINUE 

H<1,1)-(1. 0,0.0) 

c 

RETURN 

END 

c 

c 

c 

c 

subroutine UPCON (num) 

integer num, npass, imean, nwind, nxout , nyout, udnwind, 

> row, col 

complex xcdata (512, 512) ,ycdata (512, 512) 

common /fftifft/ nxout, nyout, prcnt, imean, fold, itypefold 

common /comps/ xcdata, ycdata 

common /udcont/ delta, zcon, udxlag, udnwind 

COMMON H (512, 512) 

COMPLEX H 
c 

if (num .eq. 1) then 
row- nyout 
col-nxout 
nx-nxout 
ny-nyout 

elseif (num .eq. 2) then 
row- nyout 
col-nxout 
nx-nxout 
ny-nyout 
endif 

***************■*•**★**★********★*********** + *****************•********** 


“UPCON" PERFORMS UPWARD OR DOWNWARD CONTINUATION ON UNIFORMLY 
GRIDDED ONE OR TWO DIMENSIONAL DATA SETS. 

************************************************************************ 


CREATE CONTINUATION FILTER 

CALL CONTIN (DELTA, ZCON, NX, NY ) 

CALL STORE (NX, NY) 
c 

c smooth the continuation filter 
C 

IF (udXLAG.gt .0.0 .and. udXLAG . le. 100 . 0) then 
if (udnwind .le. 4 .and. udnwind .gt. 0) then 
CALL FFT2D (NX,NY,1) 

CALL WINDOW (NX, NY, udXLAG, udNWIND) 

CALL FFT2D (NX, NY, -1) 
endif 
endif 
C 

C ACCESS TRANSFORM OF DATA « MULTIPLE * FILTER (CONVOLVING) 

C 

if (num .eq. 1) then 
do 500 i-l,row 
do 500 3-1, col 

xcdata(j,i) - xcdata ( j, i) *h ( j, i ) 

500 continue 

elseif (num .eq. 2) then 
do 580 i«l,row 
do 500 j-1 , col 

ycdata ( j, i ) - ycdata { j, i) *h { j, i ) 

580 continue 

endif 
c 

return 

end 

c 

c 

C 

SUBROUTINE CONTIN (DELTA, ZCON, NX, NY) 

COMMON H (512, 512) 

COMPLEX H 
C 

£***************************#**«*************************************** 

C 

C “CONTIN" COMPUTES TWO QUADRANTS (NX/2+1 BY NY) OF AN IDEA 

C UPWARD OF DOWNWARD CONTINUATION FILTER DIMENSIONED “NX" BY “NY". 

C FOR ONE DIMENSION LET NY-1. 

C ARRAY "H" MUST BE DIMENSIONED THE SAME AS IN THE MAIN PROGRAM 
C 

C "DELTA"- GRID INTERVAL IN LENGTH UNITS 

C "ZCON" - THE DEPTH OR HEIGHT AT WHICH CONTINUATION IS DESIRED. 

C (IN THE SAME LENGTH UNITS AS "DELTA", I.E. MILES, KM) 
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IF "ZCON" IS NEGATIVE FILTER WILL BE UPWARD CONTINUATION * 

IF "ZCON" IS POSITIVE FILTER WILL BE DOWNWARD CONTINUATION * 

* 

********************************************************************** 


PI2Z- 3.14159265 *ZCON /DELTA 

NX X- NX +2 

NX2-NX/2+ 1 

RNX2-1 . O/FLOAT (NX2) 

NY2-NY/2+1 

RNY2-1 . O/FLOAT (NY2) 

DO 101 IY-1,NY2 

CONI- (FLOAT (IY-1 ) *RNY2 ) **2 
S-SQRT (CONI ) 

Xl-EXP (S*PI2Z) 

H (1, IY) -CMP LX (XI, 0. 0) 

DO 101 IX-2, NX2 

S-SQRT ( (FLOAT (IX- 1 ) *RNX2 ) **2+CONl } 
Xl-EXP (S*PI2Z) 

H (IX, IY) -CMPLX (Xl, 0.0) 

H (NXX-IX, IY) -H (IX, IY) 

101 CONTINUE 

H<1, 1)-{1. 0,0.0) 

RETURN 

END 


subroutine DERIVA (num) 

integer num, npass, imean, nwind, nxout, nyout, 

> row, col 

complex xcdata (512, 512) , ycdata (512, 512) 

common /fftifft/ nxout, nyout , prcnt, imean, fold, itype fold 

common /comps/ xcdata, ycdata 

common /xyzderiv/ delta, nth, nway 

COMMON H (512, 512) 

COMPLEX H 

if (num .eq. 1) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 

elseif (num .eq. 2) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 
endif 






"DERIVA" CALCULATES THE "NTH" DERIVATIVE IN THE WAVE# 
DOMAIN OF UNIFORMLY GRIDDED ONE OR TWO DIMENSIONAL DATA SETS. 






CREATE DERIVATIVE FILTER 

CALL DERIV (NX, NY, NTH, NWAY, DELTA) 

ACCESS TRANSFORM OF DATA & MULTIPLE * FILTER (CONVOLVING) 

if (num .eq. 1) then 
do 500 i-l,row 
do 500 j-1 , col 

xcdata { j, i) - xcdata ( j, i ) *h ( j, i) 

500 continue 

elseif (num .eq. 2) then 
do 580 i-l,row 
do 580 j-l,col 

ycdata ( j, i) - ycdata ( j, i) *h ( j, i) 

580 continue 

endif 

return 

end 


SUBROUTINE DERIV (NNX, NNY, NNTH, NWAY, DELTA) 
COMMON C (512, 512) 

COMPLEX C, CON,CON2,CON3 






"DERIV" CALCULATES THE VALUES OF 2 QUADRANTS FOR THE 
"NTH" DERIVATIVE OF A (NX, NY) MATRIX. THESE VALUES ARE TO 
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BE MULTIPLIED BY THE WAVE# SPECTRUM OF THE GIVEN FIELD. * 

FOR A 1 DIMENSIONAL ARRAY SET "NY"-1 * 

ARRAY "C" MUST BE DIMENSIONED THE SAME AS IN THE MAIN PROGRAM. * 

* 

"NOTH" - THE ORDER OF DERIVATIVE DESIRED * 

"NWAY" - THE DIRECTION THE DERIVATIVE IS TO TAKEN * 

0 VERTICAL DIRECTION * 

1 HORIZONTAL DIRECTION (X) * 

2 HORIZONTAL DIRECTION <Y> * 

"DELTA" - GRID INTERVAL IN LENGTH UNITS * 

★ 

********************************************************************** 


NX-NNX 

NY-NNY 

NTH-NNTH 

NXX-NX+2 

NX2-NX/2+1 

NY Y- NY +2 

NY2-NY/2+1 

CON- (6.2831053,0.0) 

IF (NWAY. GE. 1) CON- (0.0,6.2831853) 

RNXDEL-1 .0/ (FLOAT (NX) *DELTA) 

RNYDEL-1 .0/ (FLOAT (NY) *DELTA) 

****************************************************************** 

TAKE VERTICAL DERIVATIVE IN WAVE# DOMAIN 
****************************************************************** 


if (nway .eq. 0) then 
DO 105 IX-2, NX2 

FX2- (FLOAT (IX-1) *RNXDEL) 

C(IX,1)- (CON*FX2)**NTH 
105 C (NXX-IX, 1 ) - (CON*FX2) **NTH 
C(l,l) - (0.0, 0.0) 

DO 110 IY-2, NY2 
I YY-NYY-IY 

FY2- (FLOAT < I Y — 1 ) *RNYDEL) 

C (1, IYY) - (CON*FY2) * *NTH 
C (1, IY) - (CON*FY2) **NTH 
FY2-FY2**2 
DO 110 IX-2, NX2 

FX2- (FLOAT (IX-1) *RNXDEL) * *2 
S-SQRT (FX2+FY2) 

CON2- (C0N*S) **NTH 
C (NXX-IX,IYY) - CON2 
C (IX, IYY) - CON2 
C (NXX-IX, I Y) - CON 2 
110 C (IX, IY) - CON2 
RETURN 

****************************************************************** 

TAKE HORIZONTAL (Y) DERIVATIVE IN WAVE# DOMAIN 
****************************************************************** 


elseif (nway .eq. 2) then 
DO 205 IX-1, NX 
205 C(IX,1) - (0.0, 0.0} 

DO 210 IY-2, NY2 
I YY-NYY-IY 

CON2- (FLOAT (IY— 1 ) *RNYDEL*CON) **NTH 
CON3-CONJG (CON2) 

DO 210 IX-1, NX 

C (IX, IYY) - CON3 
210 C (IX, IY) - CON2 

RETURN 


TAKE HORIZONTAL (X) DERIVATIVE IN WAVE# DOMAIN 
****************************************************************** 


elseif (nway .eq. 1) then 
DO 305 IY-1, NY2 

C (1, NYY— IY) - (0.0, 0.0) 

305 C ( 1 , IY ) - (0. 0,0.0) 

DO 310 IX-2, NX2 
IXX-NXX-IX 

CON2- (FLOAT (IX-1 ) *RNXDEL*CON) * *NTH 
CON3-CONJG (CON2) 

C(IXX,1) - CON 3 
C(IX,1) - CON2 

DO 310 IY-2, NY2 

C (IXX, NYY-IY) -CON3 
C (IXX, IY) -CON3 
C (IX, NYY-IY) -CON2 
310 C (IX, IY) -CON2 

RETURN 
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else 

write (*,*) 'nway is not equal to 0,1 or 2' 
stop 
endif 
c 

end 

c 

c 

c 

c 

subroutine MAG2P0L (num) 

integer num, npass , imean , nwlnd, nxout , nyout , 

> row, col 

complex xcdata (512, 512) ,ycdata (512, 512) 

common /fftifft/ nxout, nyout , prcnt, imean, fold, itype fold 

common /comps/ xcdata, ycdata 

common /rtp/ azm,xinc,dec 

COMON H (512, 512) 

COMPLEX H 
C 

if (num .eq. 1) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 

elseif (num .eq. 2) then 
row-nyout 
col-nxout 
nx-nxout 
ny-nyout 
endif 
C 

C ******************************+**********★*************************★** 

c 

C "MAG2POL" APPROXIMATLY CALCULATES THE CORRESPONDING MAGNETIC * 

C ANOMALY MAP DUE TO AN EARTH'S FIELD VECTOR OF 0.0 DECLINATION, * 
C AND 90.0 INCLINATION FROM AN INPUTTED MAGNETIC ANOMALY MAP WITH * 
C A KNOWN FIELD VECTOR, 
c 

C ********************************************************************** 

c 

DEC-DEC+AZM 

CALL MAG POL (X INC, DEC, NX, NY) 

C 

C ACCESS TRANSFORM OF DATA £ MULTIPLE * FILTER (CONVOLVING) 

C 

if (num .eq. 1) then 
do 500 i-l,row 
do 500 j«l,col 

xcdata ( j,i) - xcdata ( j, i) *h ( j, i ) 

500 continue 

elseif (num .eq. 2) then 
do 580 i«l,row 
do 580 j-1, col 

ycdata ( j, i) - ycdata ( j, i ) *h ( j, i) 

580 continue 

endif 
c 

return 

end 

c 

c 

C 

C 

SUBROUTINE MAGPOL (AINC, DDEC , NX, NY ) 

COMMON X (512, 512) 

COMPLEX X, CONA, CONB 

A********************************************************************** 

* 

"MAGPOL” CREATES A WAVE# RED UC T I ON-TO -MAGNETIC- POLE FILTER * 

ONTO THE ARRAY "X” IN BLANK COMON * 

THE DIMENSIONS OF THE ARRAY "X" MUST BE IDENTICAL TO THAT IN * 

THE MAIN PROGRAM. * 


"AINC” THE AVERAGE MAGNETIC INCLINATION OF THE AREA IN DEGREES. * 

"DDEC" THE AVERAGE MAGNETIC DECLINATION OF THE AREA IN DEGREES. * 

* 

RR-3. 14159265/100.0 

NX 2 -NX/ 2+1 

NX 1 -NX/ 2 

NX X- NX +2 

NY2-NY/2+1 

NYY-NY+2 

RNX-1. 0/FLOAT (NX) 

RNY-1 .0/FLOAT (NY) 

C 

SINI-SIN (AINC*RR) 
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COSI-COS (AINC*RR) 

SIND-SIN (DDEC*RR) 

COSD-COS (DDEC*RR) 

CON3-COSI *COSD 
CON2-COSI*SIND 
C 

CONA-1 . 0 /CMP LX (SINI, CON2 } **2 
CONB-CONJG {CONA) 

X(l,l)-(0. 0,0.0) 

DO 30 IX-2,NX1 
X (IX, 1) -CONA 
30 X (NXX-IX, 1 ) -CONB 
X (NX2, 1J-CONA 
C 

CONA-1. 0/CMPLX (SINI, CON3) **2 
CONB-CONJG (CONA) 

DO 50 IY-2,NY2 
IYY-NYY-IY 
FY-FLOAT (IY-1 ) *RNY 
FY2-FY*FY 
CFY-CON3*FY 
X (1, I YY ) — CONB 
X(1,IY) -CONA 
DO 40 IX-2,NX1 
IXX-NXX-IX 
FX-FLOAT (IX-1)*RNX 
CON4-SQRT (FX**2+FY2) 

X(IXX,IY)-1. 0/CMPLX (SINI, (CFY-FX*CON2 ) /CON4 > **2 
X(IX, IYY) -CONJG (X (IXX, IY) ) 

X(IX, IY) -1. 0/CMPLX (SINI, <FX*CON2+CFY> /CON4 ) * *2 
40 X (IXX, IYY) -CONJG (X ( IX, IY)) 

CON4-SQRT (0. 25+FY2) 

X(NX2, IYY) -1. 0/CMPLX (SINI, (0 . 5*CON2-CFY) /CON4}**2 
50 X (NX2 , IY) -1. 0/CMPLX (SINI, (0.5*CON2+CFY)/CON4)**2 
C 

RETURN 

end 
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program avgdifres 
character*80 filename 

integer coin, rown, colk, rowk, var, row, col, set 

dimension dndata (550, 550} , dkdata (550, 550) , avgdata(550, 550} , 

> difdata (550, 550) , ddata (550, 550) 

c 

c program description 

c avgdifres is a bashing of matrix manipulation, the program 

c will find the average of two input data sets, the difference 

c between them, and will resample (hence avg-dif-res aint science 

c great??} every other point, every third, fourth etc., point, 

c if you want the average and difference of the input matrices 

c make sure you choose to resample every data point, ie choose 

c 1 for lxl. 

c 

write (*,*) '1 FOR ONE DATA SET' 
write (*,*) '2 FOR TWO DATA SETS' 
read (*,*) set 
c 

write (*,*} 'INPUT FILE OF DAWN GRIDDED ANOMALIES OR ONE DATA SET' 
read (*,9990) filename 
9990 format (a80) 

open (10, file-filename, status- ’ old* , form** formatted' ) 
if (set .eq. 1) go to 10 

write (*,*) 'INPUT FILE OF DUSK GRIDDED ANOMALIES' 
read (*,9990) filename 

open (12, file-filename, status- ' old' , form- ' formatted* ) 

10 write (*,*) 'OUTPUT AVERAGED AND/OR RESAMPLED GRIDDED FILE' 
read (*,9990) filename 

open (20, file-filename, form-' formatted' ) 
if (set .eq. 1) go to 20 

write (*,*) 'OUTPUT DIFFERENCE GRID OF (DUSK) - (DAWN)' 
read (*,9990) filename 

open (22, file-filename, form-' formatted' ) 
c 

20 continue 

write (*,*) ‘RESAMPLE BY THIS NUMBER USE:* 
write (*,*) '1 for keeping the average grid as is' 
write (*,*) '2 for 2 degrees by 2 degrees' 

write (*,*) '3 for 3 degrees by 3 degrees and so on' 

read (*,*) var 
c 

read (10,*) coin 
read (10,*) rown 
read (10, * ) xcolat 
read (10,*) xlong 
read (10,*) xgridspc 
40 do 50 i-l,rown 

read (10,*) (dndata (i, j) , j-1 , coin) 

50 continue 

if (set .eq. 1) go to 170 
read (12,*) colk 

read <12, * > rowk 

read (12,*) ycolat 

read (12,*) ylong 

read (12,*) ygridspc 

80 do 100 i-1 , rowk 

read (12,*) (dkdata (i, j) , j-1 , colk) 

100 continue 
c 

if (coin. ne . colk .or. rown. ne. rowk) then 

write (*,*) 'HEY NCW KIDS GRIDS ARE DIFFERENT SIZES' 
write (*,*) coin, rown, colk, rowk 
go to 999 
endif 
c 

c find the average and difference matrices also 

c calculate the total and average RMS difference. 

totrms-Q.O 
do 150 i-1, rown 
do 150 j-1, coin 

avgdata (i, j) - ( (dndata (1, j) +dkdata (i, j) ) /2.0) 
difdata (i, j) -dkdata (i, j) -dndata (i, j) 

totrms-totrms+ ( (sqrt ( (dndata (i, j)-dkdata (i, j) ) **2) ) /2.0) 

150 continue 

avgrms-totrms/ (real (rown) *real (coin) ) 
c 

170 if (set .eq. 1) then 
do 100 i-1, rown 
do 180 j-1, coin 

avgdata (i, j)-dndata (i, j) 

180 continue 

endif 
c 

c this is the section that resamples 

row-1 

il-1 
200 jj-1 
col-1 

250 ddata (ii, jj) -avgdata (row, col) 


C 39 




wot 



col-col+var 

if (col .gt. coin) go to 300 

jj-jJ+1 

go to 250 
300 row-row+var 

if (row .gt. rown) go to 400 
ii-ii+1 
go to 200 
400 continue 
c 

write (*,*) 'new rows-',ii,' new cols-',jj 

write (20,*) jj 

write (20,*) ii 

write (20,*) xcolat 

write (20,*) xlong 

write (20,*) real(var) 

do 450 k-l,ii 

write (20,9992) (ddata (k, 1) , 1-1, j j) 

450 continue 

9992 format (6 (f 11 . 4, lx) ) 
c 

if (set .eq. 1) go to 999 
write (22,*) coin 
write (22,*) rown 
write (22,*) ycolat 
write (22,*) ylong 
write (22,*) ygridspc 
do 500 m-l,rown 

write (22,9992) (dl f data (m, n) , n-1, coin) 
500 continue 

write (*,*} 'total rms difference- ', tot rms 
write (*,*> 'average rms difference- avgrms 
c 

999 continue 
close (10) 
close (12) 
close (20) 
close (22) 
stop 
end 
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program sqrmap 
character*80 filename 

dimension xcore (100000) ,xxmag (100000) , 

> core (361,361) ,xmag(361, 361) , xmultmag (400) 

c 

c program description 

c this program will find a least squares value of x that 

c can be multiplied by the difference matrix so that the 

c difference closer fits the dawn or dusk, matrix, the 

c value of x is multiplied by the difference and subtracted 

c from the dawn or dusk grid to make an output grid, 

c NOTE: i realize i'm making the 2-D arrays 

c into 1-D arrays 

c 

write (*,*) 'input difference matrix' 
read (*,9990) filename 
9990 format (a80) 

open (10, file- filename, form- 'formatted' ,status-’ old' ) 
write (*,*) 'input dawn or dusk matrix of total field values' 
read (*,9990) filename 

open (11, file-filename, form- ' formatted' , status-' old* ) 
write (*,*) 'output (total field) - (x) (difference) ' 
read (*,9990) filename 

open (20, file-filename, form- 1 formatted' ) 
c 

cmean-0. 0 
fmean-0. 0 
read (10,*) icol 
read (10,*) irow 
read (10,*) south 
read (10,*) west 
read (10,*) gridspc 
do i-1, Irow 

read (10,*) (core (i, j) , j-1, icol ) 
do j-1, icol 

cmean-cmean+core (i, j) 
enddo 
enddo 
c 

read (11,*) imcol 
read (11,*) imrow 
read (11,*) south 
read (11,*) west 
read (11,*) gridspc 
do 1-1, imrow 

read (11,*) (xmag (1, j) , j-1, imcol) 
do j-1, imcol 

fmean-fmean+xmag (i , j) 
enddo 
enddo 

if (irow.ne. imrow .or. icol . ne. imcol ) then 
write (*,*) 'rows cor mag ', irow, imrow 
write (*,*) 'cols cor mag ' , icol, imcol 
stop 10 
endif 

cmean-amean/real (irow*icol) 
fmean-fmean/real (irow*icol) 
c 


c remove the mean values 

do 500 i-1, irow 
do 500 j-1, icol 

xmag (i, j)-xmag(i, j)-fmean 
500 core (i, j)-core (I, j) -cmean 

c 

c turn the 2-D arrays into 1-D (cheater) 


do i-1 , Irow 
do j-1, icol 

ii-( (i-l)*iC0l)4 j 

xxmag (ii)-xmag(i, j) 
xcore (ii) -core (i, j) 
enddo 
enddo 


c find a scalar value of c transpose c 

ctc=0.0 
do 600 i-l,ii 

600 etc- (xcore (i) ‘xcore (i) )+ctc 

c 

c find (c transpose c) inverse 

ctcinv-1 . 0/ctc 
c 

ctf-0.0 
do 700 i-l,ii 

700 ctf- (xcore (i) *xxmag (i) )+ctf 

c find x 


x-ctcinv*ctf 

write (*,*) 'the value of x - x 
c 

write (20,*) imcol 
write (20,*) imrow 
write (20,*) south 
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write (20,*) west 
write (20,*) gridspc 
do i-l,irow 
do j-1 , icoi 

xmultmag (j) -xmag (i, j)- (x) * (core (i, j) ) 
enddo 

write (20,9991) (xmultmag ( j) , j-1, icol) 
enddo 

9991 format ( 6 (fll . 4 , lx) ) 

999 continue 
stop 
end 
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program inversion 

DIMENSION DW (3982 } , DP (3982) ,DFS (361,44) 

COMMON XORD, YORD, DXD, DYD, NXD, NYD, RO, RD , E, G, COST, SINT, YC, THETA, PHI , 

> P (3982), TMAG (3902), DF (361, 44) ,S (7930153) 

EQUIVALENCE (DW (1 ) , P (1 ) ) , (DP (1 ) , TMAG (1 ) ) 

REAL I, INC (361 ) ,D, DEC (361 ) , FLD (361 ) , 1 1 , D1 , FI , myear, mi,md, 

> mil , mdl , mf 1 , mxoro, myoro, mdxo, mdy o, mel vo 
real fldd, f ldo, incd, inco, deed, deco 

dimension fldd (44, 101 ) , fldo (44, 361 ) , incd (44 , 181) , inco(44, 361 ) , 

> deed (44, 1 81 ) , deco (44 , 361 ) 
common /gmf/ fldd, fldo, incd, inco, deed, deco 
character*80 filename 

integer choice 
C 

£***************************************************♦******************* 

c 

c PROGRAM NVERTSM CALCULATES A SET OF CGS-SUSCEPTIBILITIES FOR AN 

C NXD -BY -NYD SPHERICAL ARRAY OF POINT DIPOLES SUCH THAT THE RE SUL - 

C TANT EQUIVALENT SOURCE FIELD IS A LEAST-SQUARES BEST FIT TO MAG- 
C NETIC DATA OBSERVED OVER AN NXO-BY-NYO SPHERICAL GRID. OUTPUT 

C CONSISTS OF LISTINGS AND/OR PUNCHED DECKS OF EQUIVALENT SOURCE 

C SUSCEPTIBILITIES AND/OR ANOMALY VALUES (SEE DATA CARD 1 BELOW) . 

C 

C DIMENSIONING REQUIREMENTS 

C DIMENSION DW (NXD* NYD), DP (NXD*NYD),P (NXD*NYD) , TMAG (NXD* NYD) , 

C DF (NXO, NYO) , S (NI J) WHERE NI J- (NXD* NYD) * (NXD*NYD+1 ) /2, FLD 1 (NXD) , 

C INC1 (NXD) , D1 (NXD) , FLD (NXO), I (NXO), D (NXO) 

C 

c this program has been slightly modified from a view point of 
c lines of code, these changes are all lower case, however from 

c the view point of run time it should now take less than 1/4 ! I ! 

c of the time that it took in the past, this is because no reads 

c from files 10 or 11 are necessary as all arrays are stored in 

c memory . 

c 

c modifications made 15 may 90 

c 

c further changes on 22 Sep 90 

c these changes are mostly removal of unnecessary write 

c statements and general cleanup of the program, 

c 

more changes on 2 Jan 91 

this update included the addition of a few lines of code 
that allows for input of a file of susceptibilities and 
output of a magnetic field map. 

****************** DATA INPUT SEQUENCE ****************************** 

write (*,*) '0 IF YOU HAVE A FILE FOR THE VARIABLES' 

write (*,*) ' 1 IF YOU WANT TO TYPE VARIABLES INTERACTIVELY' 

read {*,*} choice 

if (choice .eq. 0) go to 10 

write (*,9991) 

9991 format ('NFLD-0 DO NOT CALCULATE EQUIVALENT SOURCE M-FIELD ' / 

> • -1 CALCULATE EQUIVALENT SOURCE M-FIELD'/ 

> ' -2 GIVEN THE CGS-SUSCEPTIBILITIES THE PROGRAM'/ 

> • WILL CALCULATE THE EQUIV SRC M-FLD 1 / 

> ' NIO-0 DO NOT WRITE A FILE SUSCEPTIBILITIES'/ 

> * -I WRITE OUT A SEPARATE FILE OF SUSCEPTIBILITIES'/ 

> * NFLD(l) NIO (0) ' ) 
read (*,*} nfld, nio 

c 

if (nfld .eq. 1) then 

write (*,*) ' ' 

write (*,*) ’the following refers to calculation of the', 

> ' susceptibilities' 

write (*,*) ' ' 

endif 

write (*,9992) 

9992 format ('NXO- NUMBER OF LONGITUDINAL COLS OF OBSERVATION GRID'/ 

> ' NYO— NUMBER OF LATITUDINAL ROWS OF OBSERVATION GRID'/ 

> ' XORO- WESTERN-MOST LONGITUDINAL COORDINATE OF OBSERVATION'/ 

>* GRID IN -180.0 to 180.0 DEGREES'/ 

> ' YORO- SOUTHERN-MOST LATITUDINAL COORDINATE OF OBSERVATION'/ 

>' GRID IN -90.0 to 90.0 DEGREES'/ 

> 1 DXO- LONGITUDINAL STATION SPACING OF OBSERVATION GRID IN DECS'/ 

> 1 DYO- LATITUDINAL STATION SPACING OF OBSERVATION GRID IN DEGS'/ 

> ’ ELVQ— ELEVATION OF OBSERVATION GRID IN KILOMETERS (350.0)'// 

> ' NXO NYO XORO YORO DXO DYO ELVO '} 
read (*,*) nxo, nyo, xoro,yoro,dxo, dyo, elvo 
c 

write (*,9993) 

9993 format ('NXD- NUMBER OF LONGITUDINAL COLS OF SOURCE GRID'/ 

> * NYD= NUMBER OF LATITUDINAL ROWS OF SOURCE GRID'/ 

> ' XORD- WESTERN-MOST LONGITUDINAL COORDINATE OF SOURCE'/ 

>' GRID IN -180.0 to 180.0 DEGREES'/ 

> 1 YORD- SOUTHERN -MO ST LATITUDINAL COORDINATE OF SOURCE'/ 

>' GRID IN -90.0 to 90.0 DEGREES'/ 

> ' DXD- LONGITUDINAL STATION SPACING OF SOURCE GRID IN DEGREES'/ 

> ' DYD- LATITUDINAL STATION SPACING OF SOURCE GRID IN DEGREES'/ 
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>'ELVD- ELEVATION OF SOURCE GRID IN KILOMETERS (-50.0)*// 

>'NXD NYD XORD YORD DXD DYD ELVD ') 
read (*,*) nxd,nyd, xord,yord,dxd,dyd, elvd 

write (*, 9994 > 

9994 format {'YEAR- EPOCH IN YEARS AND DECIMAL FRACTION YEARS'/ 

>' E.G. , 1965.75 - 1 OCT 65 FOR WHICH THE*/ 

>' GEOMAGNETIC REFERENCE FIELD IS TO'/ 

>* BE COMPUTED AT SOURCE AND/OR OBSERVATION POINTS'/ 

>' - 0 USER SUPPLIES CHARACTERISTICS OF SOURCE POLARIZATION'/ 

>' FIELD (Fl, 11, Dl) AND GEOMAGNETIC FIELD <I,D) OVER'/ 

>' OBSERVATION GRID'/ 

>'F1- SCALAR MAGNETIC INTENSITY IN GAt-WAS OF SOURCE POLARIZATION'/ 
>' FIELD.'/ 

>'I1- INCLINATION IN DEGREES OF SOURCE POLARIZING FIELD'/ 

> ' Dl- DECLINATION IN DEGREES OF SOURCE POLARIZING FIELD*// 

>' NOTE IF (F1+I1+D1) .EQ.0.0, THEN THE SOURCE POLARIZING*/ 

>' FIELD IS COMPUTED BY SUBROUTINE FIELDG FOR EPOCH'/ 

>' SPECIFIED BY THE YEAR-INPUT VARIABLE'// 

>' YEAR (1980.0) Fl (0.0) II (0.0) Dl (0.0)') 
read <*,*) year, f 1 , il , dl 

write (*,9995) 

9995 format ( * I- INCLINATION IN DEGREES OF THE GEOMAGNETIC FIELD'/ 

>' OVER THE OBSERVATION POINTS'/ 

> ' D- DECLINATION IN DEGREES OF THE GEOMAGNETIC FIELD OVER THE'/ 

>' OBSERVATION POINTS'// 

> ' NOTE IF ( I -+-D ) .EQ.0.0, THEN THE GEOMAGNETIC FIELD OVER THE'/ 

>' OBSERVATION POINT IS COMPUTED BY SUBROUTINE FIELDG'/ 

>' FOR THE EPOCH SPECIFIED BY THE YEAR-INPUT VARIABLE'// 

>'I (0.0) D (0.0)') 
read <*,*> i,d 

write (*,*) 'ERROR FACTOR FOR VARIANCE (fak) (0 . 10E-7 ) ' 
read (*,*) fak 

if (nfld .eq. 0) go to 15 
write (*,*) ' 1 

write (*,*) 'the following refers to calculation of the' 
write (*,*) 'equivalent source magnetic field' 
write (*,*) ' ' 

write (*,9990) 

9998 format (*mNXO- NUMBER OF LONGITUDINAL COLS OF OBSERVATION GRID'/ 

> ' mNYO- NUMBER OF LATITUDINAL ROWS OF OBSERVATION GRID'/ 

>'mXORO« WESTERN-MOST LONGITUDINAL COORDINATE OF OBSERVATION'/ 

>' GRID IN -180.0 to 180.0 DEGREES'/ 

> * mYORO- SOUTHERN-MOST LATITUDINAL COORDINATE OF OBSERVATION'/ 

>' GRID IN -90.0 to 90.0 DEGREES'/ 

> ' mDXO- LONGITUDINAL STATION SPACING OF OBSERVATION GRID IN DEGS'/ 

> ' mDYO- LATITUDINAL STATION SPACING OF OBSERVATION GRID IN DEGS’/ 
>’mELVO- ELEVATION OF OBSERVATION GRID IN KILOMETERS (350.0)'// 
>‘mNXO mNYO mXORO mYORO mDXO mDYO mELVO ') 
read (*,*} mnxo,mnyo,mxoro,myoro,mdxo,mdyo, melvo 

write (*,9996) 

9996 format ('mYEAR- EPOCH IN YEARS AND DECIMAL FRACTION YEARS'/ 

>' E.G., 1965.75 - 1 OCT 65 FOR WHICH THE'/ 

>' GEOMAGNETIC REFERENCE FIELD IS TO'/ 

>' BE COMPUTED AT SOURCE AND/OR OBSERVATION POINTS*/ 

>' - 0 USER SUPPLIES CHARACTERISTICS OF SOURCE POLARIZATION'/ 

>* FIELD (Fl , I 1 , Dl ) AND GEOMAGNETIC FIELD (I,D) OVER*/ 

>* OBSERVATION GRID*/ 

> ' mFl- SCALAR MAGNETIC INTENSITY IN GAMMAS OF SOURCE POLARIZATION'/ 
>* FIELD.'/ 

>'mll- INCLINATION IN DEGREES OF SOURCE POLARIZING FIELD'/ 

>'mDl- DECLINATION IN DEGREES OF SOURCE POLARIZING FIELD'// 

> ' NOTE IF (mFl+mll+mDl ) .EQ.0.0, THEN THE SOURCE POLARIZING'/ 

>' FIELD IS COMPUTED BY SUBROUTINE FIELDG FOR EPOCH'/ 

>' SPECIFIED BY THE YEAR-INPUT VARIABLE'// 

> ' mYEAR (0.0) mFl (60000.0) mil (90.0) mDl (0.0)') 
read (*,*) myear,mf l,mil,mdl 

write (*, 9997) 

9997 format ('ml- INCLINATION IN DEGREES OF THE GEOMAGNETIC FIELD'/ 

>* OVER THE OBSERVATION POINTS'/ 

>'mD- DECLINATION IN DEGREES OF THE GEOMAGNETIC FIELD OVER THE'/ 

>' OBSERVATION POINTS'// 

> ' NOTE IF (ml+mD) .EQ.0.0, THEN THE GEOMAGNETIC FIELD OVER THE'/ 

>' OBSERVATION POINT IS COMPUTED BY SUBROUTINE FIELDG'/ 

>' FOR THE EPOCH SPECIFIED BY THE YEAR-INPUT VARIABLE'// 

> 'ml (90.0) mD (0.0)') 
read <*,*) mi,md 

write (*,*) '0 DO NOT SUBTRACT MEAN OF FINAL R-T-P MAP' 

write (*,*) *1 SUBTRACT THE MEAN' 
read (*,*) isub 
go to 15 

10 write (*,*) 'INPUT FILE OF NUMBERS FOR VARIABLES* 
read (*,9990) filename 

open (17, file-filename, status- ' old* , form= ' format ted' ) 
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c 

15 


c 

c 

c 


9990 


c 

c 


c 

c 


READ (17,*) 
READ (17,*) 
READ (17,*) 
READ (17,*) 
read (17,*) 
read (17,*) 
read (17,*) 
read (17,*) 

write (*,*) 
write (*,*) 


NFLD, NIO 

NXO, NYO, XORO, YORO, DXO, DYO, ELVO 
NXD, NYD, XORD, YORD, DXD, DYD, ELVD 
YEAR, FI, II, Dl, I, D 
fak 

mnxo, mnyo, mxoro, myoro, mdxo, mdyo,melvo 

myear,mf l,mil ,mdl,mi,md 

isub 

'INPUT FILE OF GRIDDED ANOMALY DATA OR SUSC DATA' 
'DATA SHOULD BE WEST TO EAST AND SOUTH TO NORTH' 
array df (ix, jy) reads the anomaly data 
in gammas or nanoteslas with the input 
starting with the southernmost latitude 


at the westernmost longitude. 

read (*,9990) filename 
format (a80) 

open (13, file-filename, status- ' old' , form-' formatted' ) 
write (*,*} 'INPUT FILE OF SPHERICAL HARMONIC COEFFICIENTS' 
write (*,*) 'SUCH AS GSFC1283' 
read (*,9990) filename 

open (3, file-filename, status-' old* , form-’ formatted' ) 
open (3, file-' . . / data/mgst 1 283 ', status- ' old' , 

> form=» ' formatted' ) 

if (nfld .eq. 1 .or. nfid .eq. 2) then 

write (*,*) 'OUTPUT FILE OF EQUIVALENT SOURCE M-FIELD' 
read (*,9990) filename 

open (30, file-filename, form-' formatted' ) 
endif 


if (nio .eq. 1) then 

write (*,*) 'OUTPUT FILE OF SUSCEPTIBILITIES' 
read (*,9990) filename 
open (33, file-filename, form- ' formatted') 
endif 

write (*,*) 'OUTPUT INFORMATION FILE OF A BUNCH OF STUFF!!' 

read (*,9990) filename 

open (6, file-filename, form-' formatted' ) 


if (nfld .eq. 2) go to 155 


WRITE (6, 520) NXO, NYO,XORO, YORO, DXO, DYO, ELVO 
WRITE (6, 540) NXD, NYD, XORD, YORD, DXD, DYD, ELVD 


IF 

IF 

IF 

IF 


(YEAR. LT . 1 . E-9) WRITE<6,420) Fl,Il,Dl,I,D 

(FI +1 l+Dl . LT . 1 . E-9 .AND. I+D . GT .0.0) WRITE(6, 430) YEAR, I, D 

{ I + D . LT. 1 . E-9. AND . Fl + I 1 +D1 . GT .0.0) WRITE(6,440) YEAR, FI, II , Dl 

(I+D.LT. 1 .E-9.AND.F1+I1+D1 .LT.l . E-9) WRITE(6, 450) YEAR 


CALCULATE THE GEOMAGNETIC FIELD OVER THE SOURCE AND/OR OBSERVATION 
GRIDS, RESPECTIVELY 


IF (YEAR. LT. 1 . E-9) GO TO 120 
LQ-1 


CALL FIELDG (0. , 0. , 0. , 0. , 55, LQ, Ql, Q2, Q3, Q4 ) 

IF (Fl+Il+Dl .GT. 0 . 0) GO TO 110 

CALL GEOMAG (YEAR, ELVD, YORD, XORD, DYD, DXD, NYD, NXD, 11 ) 
110 IF (I+D. GT. 0.0) GO TO 120 


CALL GEOMAG (YEAR, ELVO, YORO, XORO, DYO, DXO, NYO, NXO, 10 ) 
120 CONTINUE 


read (13,*) lew 
read (13,*) ins 
read (13,*) scolat 
read (13,*) west 
read (13,*) gridspc 
DO 130 JY-1 , NYO 

READ (13,*) (DF(IX,JY) , IX-1, NXO) 
130 continue 


COMPUTE MAXIMUM, MINIMUM AND AVERAGE AMPLITUDE VALUES FOR M-FIELD 


DSUM-0.0 
DMIN-DF (1,1) 

DMAX -DMIN 
DO 140 JY-1, NYO 
DO 140 IX-1, NXO 

DSUM-DSUM+DF (IX, JY) 

IF (DMAX. LT.DF (IX, JY) ) DMAX-DF ( IX, JY ) 
IF (DMIN . GT . DF (IX, JY) ) DMIN-DF (IX, JY ) 
140 CONTINUE 

D SUM- D SUM/ FLOAT (NXO* NYO) 

WRITE (6, 640) DMAX, DMIN, D SUM 
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c save values for the reduction-to-pole 
c 

155 istrnxd-nxd 
istrnyd-nyd 
strxord-xord 
stryord-yord 
strdxd-dxd 
strdyd-dyd 
strelvd-elvd 

if (nfld .eq. 2) go to 840 
c 

C CONVERT LAT AND LONG TO RADIANS AND ELEVATIONS TO EARTH RADII 

C 

PI-3.1415926536 
FACT-PI /I 80.0 
C 

XORQ-XORO* FACT 
XORD-XORD* FACT 
YORO- (90 . 0-YORO ) * FACT 
YORD- ( 90 . 0-YORD ) * FACT 
DXO-DXO*FACT 
DXD-DXD * F ACT 
DYO— DY O* FACT 
DYD— DYD*FACT 
C 

I -I* FACT 
D— D*FACT 
I 1*11* FACT 
Dl — Dl *FACT 
C 

REARTH-6371 . 0 

RO-ELVO+REARTH 

RD-ELVD+REARTH 

E-RD**2+RO**2 

G«2.0*RD*RO 

NP- (NXD*NYD) 

DO 150 JY - 1 , NP 
P ( JY) -0. 0 
DW (JY) -0. 0 
150 CONTINUE 
C 

NIJ-NP* (NP+U/2 
DO 160 JY-1, NI J 
160 S ( JY) -0. 0 
C 

C COMPUTE WEIGHTING COEFFICIENTS, DW(L), L-1,NP 

C 

C COMPUTE UPPER HALF OF SY>METRIC A (TRANSPOSE ) A MATRIX OF 1-ST ORDER 

C PARTIALS AND STORE AS 1-DIMENSIONAL ARRAY S(LLL), LLL-1,NIJ I.E. 

C A (TRANSPOSE) A (I, J)-S(IJ) , WHERE I J-I* (1-1) /2+J 
C 

IF (YEAR. LT. 1 . E-9 ) GO TO 180 

IF (Fl+I 1+Dl .GT .0.0. AND . I+D. LT. 1 . E-9) GO TO 200 
IF (Fl+Il+Dl .LT.1.E-9.AND. I+D.GT.0.0) GO TO 220 
C 

C COMPUTE A (TRANSPOSE) A MATRIX FOR CASE WHERE (I,D) AND (Fl,Il,Dl) 

C ARE DERIVED FROM FIELDG 

C 

DO 170 JY-1 , NYO 

THETA- YORO + (FLOAT (JY) -1 . 0 ) *DYO 
COST-COS (THETA) 

SI NT-SIN (THETA) 

C 

do 175 1-1, nxo 

fld(l ) -f ldo ( jy, 1) 
inc <1 ) -inco ( jy, 1) 
dec (1) -deco (jy, 1) 

175 continue 

DO 170 IX-1, NXO 

PHI-XORO+ (FLOAT (IX) -1 . 0) *DXO 
AI-INC(IX) 

AD-DEC (IX) 

C 

CALL MAGSl (AI, AD) 

C 

DY-DF (IX, JY) -YC 
LLL-Q 

DO 170 L-l , NP 

DW (L) -DW (L) +TMAG (L) *DY 
DO 170 K-l, L 
LLL-LLL+1 

S (LLL) -S (LLL) +TMAG (L) *IMAG (K) 

170 CONTINUE 
GO TO 240 
C 

C COMPUTE A (TRANSPOSE) A MATRIX FOR CASE WHERE USER SUPPLIES (I,D) 

C AND (FI, II , Dl) 

C 

180 DO 190 JY-1, NYO 

THETA- YORO + (FLOAT (JY) -1 . 0) *DYO 
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COST-COS (THETA) 

SINT-SIN (THETA) 

DO 190 IX-1, NXO 

PHI-X0R04 (FLOAT (IX) -1.0)*DXO 
C 

CALL MAGS2 (I, D, Fl, II , D1 ) 

C 

DY-DF (IX, JY) -YC 
C 

LLL-0 

DO 190 L— 1 , NP 

DW (L) -DW (L) +TMAG (L) *DY 
DO 190 K-1,L 
LLL-LLL+1 

S (LLL) -S (LLL) +TMAG (L) *TWAG (K) 

190 CONTINUE 
GO TO 240 

COMPUTE A (TRANSPOSE) A MATRIX FOR CASE WHERE (I,D) ARE DERIVED 
FROM FIELDG AND USER SUPPLIES (Fl,Il,Dl) 

200 DO 210 JY-1 , NYO 

THETA- Y0R04 (FLOAT (JY) -1 . 0) *DYO 
COST-COS (THETA) 

SINT-SIN (THETA) 

C 

do 185 1-1, nxo 

fld(l) -fldo ( jy, 1) 
inc (1 ) -inco ( jy, 1) 
dec (1) -deco ( jy, 1) 

185 continue 

c 

DO 210 IX-1, NXO 

PHI-X0R04 (FLOAT (IX ) -1 .0) *DX0 
AI-INC (IX) 

AD-DEC (IX) 

C 

CALL MAGS2 (AI , AD, Fl , II , D1 } 

C 

DY-DF (IX, JY) -YC 
C 

LLL-0 

DO 210 L— 1 , NP 

DW (L) -DW (L) +TMAG (L) *DY 
DO 210 K-l, L 
LLL-LLL+l 

S (LLL) -S (LLL) 41MAG (L) *TMAG (K) 

210 CONTINUE 
GO TO 240 
C 

C COMPUTE A (TRANSPOSE) A MATRIX FOR CASE WHERE USER SUPPLIES (I,D) 

C AND (Fl , I 1 , D1 ) ARE DERIVED FROM FIELDG 

C 

220 DO 230 JY-1 , NYO 

THETA-YORO+ (FLOAT ( JY) -1.0) *DYO 
COST-COS (THETA) 

SINT-SIN (THETA) 

DO 230 IX-1, NXO 

PHI-XORO+ (FLOAT (IX) -1.0) *DXO 
C 

CALL MAGS1 (I,D) 

C 

DY-DF (IX, JY) -YC 
LLL-0 

DO 2 30 L— 1 , N P 

DW (L) -DW (L) +TMAG (L) ♦DY 
DO 230 K-l, L 
LLL-LLL+1 

S (LLL) -S (LLL) +TMAG (L) *TMAG (K) 

230 CONTINUE 
240 CONTINUE 


C if a transpose a without error 

c variance is wanted then use 

c write (20) . 

c WRITE (20) (S(J), J-1,LLL) 

c if a transpose observations without 

c error variance is wanted then use 

c write (25) . 

C WRITE (25) (DW (L) , L-l, NP) 

c 

c the following loop adds fak to the diagonal 

c of aTa 

II-O 

DO 888 J-l, NP 
II-II+J 

S (II ) -S (II) +FAK 


888 CONTINUE 
C 

C COMPUTE INVERSE OF S-ARRAY 

C 
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CALL SPPCO (S,NP, RCOND,DP,INFO) 

C 

WRITE (6, 400) RCOND 
IF (INFO.NE.0) WRITE (6, 490) INFO 
DO 250 IX-1 , NP 
250 DP (IX) -DW (IX) 

C 

CALL SPPSL (S,NP,DP) 

C 

C WRITE OUT COORDINATE CHARACTERISTICS OF M-DIPOLES 
C 

WRITE (6, 590) 

L-0 

DO 260 JY-1, NYD 

YLAT-90. 0- (YORD+FLOAT (JY-1) * DYD) /FACT 
DO 260 IX-1,NXD 
L-L+l 

XLON- (XORD+ FLOAT (IX-1 ) *DXD) /FACT 
WRITE (6, 600) DP(L),XLON,YLAT,ELVD 
260 CONTINUE 

DO 270 JY-1, NP 
270 P ( JY) -DP ( JY) 

C 

C IF NIO - 1 WRITE SUSCEPTIBILITIES ONTO USER DEFINED UNIT 33 
C 

If (nio .eq. 1) then 
write (33, * ) lew 
write (33,*) ins 
write (33,*) scolat 
write (33,*) west 
write (33,*) gridspc 
IJK-1 

DO 375 JY-1, NYD 
I JK1-I JK+NXD-1 

WRITE (33, ' (4 (E18.8, lx) ) ') (DP (L),L-IJK, IJK1) 

I JK-IJKl+1 
375 CONTINUE 

endif 
C 

IF (NFLD.eq. 0) GO TO 410 
WRITE (6,620) 

C 

C COMPUTE EQUIVALENT SOURCE M-FIELD 
C 

040 continue 

WRITE (6, 630) 
nxd-istrnxd 
nyd-istrnyd 
xord-strxord 
yord-stryord 
dxd-strdxd 
dyd-strdyd 
elvd-strelvd 
if (nfld .eq. 2) then 
read (13,*) iew 
read (13,*) ins 
read (13,*) scolat 
read (13,*) west 
read (13,*) gridspc 
do jy-l,nyd 

read (13,*) (df (ix, jy) , ix-1, nxd) 
enddo 

DO JY-1 , NYd 
do ix-l,nxd 

L» ( ( jy-1) *nxd)+ix 
P(L)-df (ix, jy) 
enddo 
enddo 
endif 
c 

IF (mYEAR. LT. 1 .E-9) GO TO 880 

call fieldg (0 . , 0. , 0. , 0. , 55, 1, ql, q 2, q3, q4 ) 

if (mf 1+mil+mdl .gt. 0.0) go to 870 

call geomag (myear, elvd, yord, xord, dyd, dxd, nyd, nxd, 1 1 ) 

870 if (mi+md .gt. 0.0) go to 880 

call geomag (myear, melvo,myoro,mxoro,mdyo,mdxo,mnyo,mnxo, 10) 
c 

880 continue 
c 

PI-3.1415926536 
FACT-PI /I 80.0 
C 

mXORO-mXORO* FACT 
XORD -XORD* FACT 
mYORO- ( 90 . 0-mYORO) * FACT 
YORD- (90. 0-YORD) *FACT 
mDXO-mDXO* FACT 
DXD-DXD*FACT 
mDYO— mDYO+FACT 
DYD— DYD* FACT 
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ml -ml* FACT 
mD— mD* FACT 
mil-mil* FACT 
mDl — mDl*FACT 
C 

REARTH-6371 .0 
RO-mELVO+REARTH 
RD-ELVD+REARTK 
E-RD**2+RO**2 
G-2 . 0*RD*RO 
c 

IF (mYEAR.LT.l.E-9) GO TO 300 

IF (mFl+mll+mDl .GT.O. 0 .AND. ml+mD .LT. 1 . E-9) GO TO 330 
IF (mFl+mll+mDl .LT. 1 . E-9 .AND. ml+mD.GT.O.O) GO TO 360 
c 

C COMPUTE M-FIELD FOR CASE WHERE (mI,mD) AND (mFl, mil, mDl ) 
C ARE DERIVED FROM FIELDG 

C 

DO 290 JY-1, mNYO 

THETA -mYOROt ( FLOAT ( JY ) -1 . 0) *mDYO 
COST-COS (THETA) 

SINT-SIN (THETA) 

C 

do 195 l-l,mnxo 

fld(l)-fldo(jy,l) 
inc(l)-inco( jy, 1) 
dec (l)-deco( jy, 1) 

195 continue 


DO 280 IX-1, mNXO 

PHI -mXORO+ ( FLOAT ( IX ) -1 . 0 ) *mDXO 
al-INC (IX) 
aD-DEC (IX) 

CALL MAGS1 (aI,aD) 

280 DFS (IX, JY) -YC 

290 WRITE (6, 580) (DFS (IX, JY) , IX-1, mNXO) 
GO TO 390 


C 

C COMPUTE M-FIELD FOR CASE WHERE USER SUPPLIES (mI,mD) 
C AND (mFl ,mll , mDl ) 

C 

300 DO 320 JY-1, mNYO 

THETA-mYORO+ (FLOAT (JY ) -1 . 0) *mDYO 
COST-COS (THETA) 

SINT-SIN (THETA) 

DO 310 IX-1, mNXO 

PHI-mXORO+ (FLOAT (IX) -1.0) *mDXO 
C 

CALL MAGS2 (ml , mD, mFl , ml 1 , mDl ) 

C 

310 DFS(IX, JY) -YC 

320 WRITE (6, 580) (DFS (IX, JY) , IX-1, mNXO) 

GO TO 390 


c 

c COMPUTE M-FIELD FOR CASE WHERE (mI,mD) ARE DERIVED FROM 

C FIELDG AND USER SUPPLIES (mFl, mil, mDl ) 

C 

330 DO 350 JY-1, mNYO 

THETA-mYORO+ (FLOAT (JY ) -1 . 0) *mDYO 
COST-COS (THETA) 

SINT-SIN (THETA) 

C 

do 205 l-l,mnxo 

fid (1) -f ldo ( jy, 1 ) 
inc (1) -inco ( jy, 1) 
dec (1) -deco ( jy, 1) 

205 continue 


c 

DO 340 IX-1, mNXO 

PHI-mXORO+ (FLOAT (IX) -1 .0) *mDXO 
al-INC (IX) 
aD-DEC (IX) 

C 

CALL MAGS2 (aI,aD,mFl,mIl,mDl) 

C 

340 DFS (IX, JY) -YC 

350 WRITE (6, 500 ) (DFS (IX, JY) , IX-1 , mNXO) 

GO TO 390 
C 

C COMPUTE M-FIELD FOR CASE WHERE USER SUPPLIES (mI,mD) AND 
C (mFl, mil, mDl) ARE DERIVED FROM FIELDG 

C 

360 DO 380 JY-1, mNYO 

THETA-mYORO+ (FLOAT (JY) -1 . 0) *mDYO 
COST-COS (THETA) 

SINT-SIN (THETA) 

DO 370 IX-1, mNXO 

PHI-mXORO+ (FLOAT (IX) -1.0) *mDXO 
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noon 


C 


CALL I*S\GS1 (ml, mD) 


C 

370 DFS(IX, JY)-YC 

380 WHITE (6, 580) (DFS (IX, JY) , IX-1, mNXO) 

390 CONTINUE 

COMPUTE MAXIMUM, MINIMUM AND AVERAGE AMPLITUDE VALUES FOR EQUIVA- 
LENT SOURCE M-FIELD 

D SUM-0.0 
DMIN-DFS (1,1) 

DMAX-DMIN 
DO 400 JY-l,mNYO 
DO 400 IX-1, mNXO 

DSUM— DSUM+DF S (IX, JY) 

IF (DMAX. LT.DFS (IX, JY) } DMAX-DFS (IX, JY) 

IF (DMIN. GT.DFS (IX, JY) ) DMIN-DFS (IX, JY) 

400 CONTINUE 

DSUM-D SUM/ FLOAT (mNXO*mNYO) 

WRITE (6, 640) DMAX, DMIN, DSUM 

if (isub .eq. 0) dsum-0. 0 
<±nax-df s (1,1) 
dmin-dmax 
write (30,*) mnxo 
write (30,*) mnyo 
write (30,*) myoro/fact 
write (30,*) mxoro/fact 
write (30,*) mdxo/fact 
DO 385 JY-1 , mNYO 

WRITE (30, 580) ( (DFS (IX, JY) -dsum) , IX-l,mNX0) 
do 385 ix-l,mnxo 

dmax-max (dmax, (df s (ix, jy ) -dsum) ) 
cknin-min (dmin, (dfs (ix, jy ) -dsum) ) 

385 CONTINUE 

if (isub .eq. 1) write (6,*) 'new max-', dmax,' new min-',dmin 
c 

410 CONTINUE 
S SUM-0.0 

DO 900 II-l,mNXO 
DO 900 J-l ,mNYO 

SSUM-SSUM+ (DF (II , J) -DFS (II, J) ) * *2 

900 CONTINUE 

WRITE (6, 790) SSUM 

790 FORMAT (' SUM OF SQUARES - \E15.10) 

901 CONTINUE 
STOP 

C 

420 FORMAT (/, IX, 3HF1-,F10. 3, 5X, 3HI1-, F6. 2, 5X, 3HD1-, F6.2, 5X,2HI-,F6. 2, 
1 5X, 2HD-, F6 . 2, /) 

430 FORMAT (/, IX, 5HYEAR-, F10. 5, 5X, 2HI-, F6 . 2, 5X, 2HD-, F6. 2, /) 

440 FORMAT (/, IX, 5 H YEAR-, F10.5, 5X, 3HF1-,F10. 3, 5X, 3HI1-,F6. 2, 5X, 3HDl-,F 
16.2,/} 

450 FORMAT (/, IX, 5HYEAR-, F10 . 5, /) 

480 FORMAT <//,2X, 7HRCOND -,E20.8) 

490 FORMAT (//, 2X, 26HATA LEADING MINOR OF ORDER, 15, IX, 24HIS NOT POSITI 
1VE DEFINITE) 

520 FORMAT <2X, 4HNXO-, 15, 5X, 4HNYO-, 1 5, 5X, 5HXORO-, F10. 5, 5X, 5HYORO-, F10. 

1 5, 5X, 4HDXO— , F10.5, 5X, 4HDYO-, F10 . 5, 5X, 5HELVO-, F10. 5, //) 

540 FORMAT (2X, 4HNXD-, 15, 5X, 4HNYD-, 1 5, 5X, 5HXORD-, F10. 5, 5X, 5HYORD-, F10. 

15, 5X, 4HDXD-, F10 . 5, 5X, 4HDYD-, F10 . 5, 5X, 5HELVD-, F10 . 5, //) 

580 FORMAT (8(lX,F9.3) ) 

590 FORMAT (//,* CGS-SUSCEPTIBI LI TIES *, 5X, ' E-LONGITUDE ', 5X, ' N- 1 , 

>' LATITUDE* , 5X, • KM-ELEVATION ' , / ) 

600 FORMAT (IX, E20. 5, 5X, F10 . 4, 5X, F10. 4 , 5X, F10. 4) 

620 FORMAT (///) 

630 FORMAT (//, 2X, 2 5HEQUIVALENT SOURCE M-FIELD,/) 

640 FORMAT (//, 2X, 5HDMAX-, F10. 3, 10X, 5HDMIN-, F10 . 3, 10X, 5HDAVG-, F10. 3) 

C 

END 

SUBROUTINE MAGSl (I,D) 

C 

c*********************************************************************** 
C SUBROUTINE MAGSl CALCULATES THE TOTAL MAGNETIC FIELD AT A SPHERICAL 
C OBSERVATION POINT (R, THETA, PHI ) DUE TO A SPHERICAL ARRAY OF POINT 

C DIPOLES WITH CGS-SUSCEPTIBILITIES P (L) AT SOURCE GRID COORDINATES 

C (Rl, THETA1, PHI1) . POLARIZING FIELD CHARACTERISTICS (Fl,Il,Dl) 

C ARE READ FROM TAPE11. 

£***************************************★*++**************************** 

C 

COMMON XORD, YORD, DXD, DYD, NXD, NYD, RO, RD, E, G, COST, SINT, YC, THETA, PHI, 
>P (3982 }, TMAG (3982), DF (361, 44 ),S (7930153) 
real f ldd, f Ido, incd, inco, deed, deco 

dimension f ldd (44, 181) , fldo(44, 361) , incd (44, 181) , inco (44, 361) , 

> deed (44,181) ,deco (44, 361 ) 

common /gmf /fldd, fldo, incd, inco, deed, deco 
REAL 1,11, JR, JTHETA, JPHI, INCl (181) , FLD1 (181),DEC1 (181) 

YC-0.0 

L-0 
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DO 110 JY-1 , NYD 

THETA1-Y0RD+ FLOAT (JY-1 ) *DYD 
COST 1 -COS ( TH ETA 1) 

SINT1 -SIN (THETAl > 

CTlT— COSTl *COST 
STlT-SINTl *SINT 
SC1T-SINT1 *COST 
CSlT-COSTl *SINT 
C 

do 730 k-l,nxd 

fldl (k) -fldd ( jy, k) 
incl (k) -incd ( jy, k) 
deal (k) -deed ( jy, k) 

730 continue 

C 

DO 110 IX-1,NXD 

L-L+l 

COMPUTE POINT DIPOLE POLARIZATION VECTOR IN SPHERICAL ORTHONORMAL 
UNIT VECTORS (ER, ETHETA, EPHI ) WITH SUCEP(L)-1.0 

F1-FLD1 (IX) 

Il-INCl (IX) 

D1-DEC1 (IX) 

JR-F 1 *SIN (II) 

JTHETA-Fl *COS ( II ) *COS (Dl) 

JP HI-FI* COS (II ) *SIN (Dl) 

COMPUTE MAGNETIC FIELD VECTOR (U,V,W) AT THE POINT (R, THETA, PHI ) 

DUE TO POINT DIPOLES AT (Rl , THETAl (JY ) , PHI 1 (IX) ) 

PHI 1-XORD+ FLOAT (IX-1 ) *DXD 
SINP-SIN (PHI-PHIl ) 

COSP-COS (PHI-PHIl ) 

A-CTlT+STlT*COSP 
B-SClT-CSlT*COSP 
C-SINT*SINP 
R2-E-G*A 
R15-R2* *1 . 5 
R25-R2**2.5 

XX- JR* (RD— RO* A) + JTHETA* RO*B- JPHI * RO* C 
ATHETA— CS1T+SC1T*C0SP 
BTHETA— ST1T-CT1T*C0SP 
CTHETA-COST*SINP 
APHI— SINT1*SINP 
BPHI-COST1 *SINP 
CPHI-COSP 
C 

Ul— JR*A+JTHETA*B-JPHI*C 
U2 — 3 . 0*XX* (RO-RD*A) 

U3-U1/RI5 

U4-U2/R25 

U-U3+U4 

c 

VI— JR*ATHETA+JTHETA* BTHETA- JPHI* CTHETA 
V2-3 . 0* XX* RD* ATHETA 
V3-V1/R1 5 
V4-V2/R25 
V-V3+V4 
C 

Wl=-JR*APHI+JTHETA*BPHI— JPHI *CPHI 
W2»3.0*XX*RD*APHI 
W3-W1/R15 
W4-W2/R25 
W-W3+W4 
C 

C CALCULATE THE COMPONENT OF THE ANOMALOUS FIELD IN THE DIRECTION 

C OF THE GEOMAGNETIC FIELD AT THE OBVSERVATION POINT I.E., 

C ( (U, V, W) * (UR, UTHETA, UPHI ) } *P (L) - TOTAL MAGNETIC FIELD 

C 

UR-SIN (I) 

UTHETA-COS (I ) *COS (D) 

UPHI -COS (I) *SIN(D) 

C 

TMAG (L) - UR* U+ UTHETA* V+UP HI *W 
YC-YC+P (L) *TMAG (L) 

110 CONTINUE 
C 

RETURN 

C 

END 

SUBROUTINE MAGS2 (I,D,F1, Il,Dl) 

C 

C********************************************************************»** 

C SUBROUTINE MAGS2 CALCULATES THE TOTAL MAGNETIC FIELD AT A SPHERICAL 
C OBSERVATION POINT (R, THETA, PHI ) DUE TO A SPHERICAL ARRAY OF POINT 

C DIPOLES WITH CGS-SUSCEPTIBILITIES P (L) AT SOURCE GRID COORDINATES 

C (Rl, THETAl, PHI1) . 

c*********************************************************************** 
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COMMON XORD, YORD,DXD,DYD,NXD, NYD, RO, RD, E, G, COST, SINT, YC, THETA, PHI, 
>P (3982) , TMAG (3982) , DF (361, 44) , S (7930153) 

REAL 1,11, JR, JTHETA, JPHI 

YC-0.0 

L-0 

DO 110 JY-1 , NYD 

THETAl -YORD+FLOAT (JY-1 ) *DYD 
COST1 -COS (THETA1 ) 

SI NT 1 -SIN (THETAl } 

CTlT— COSTl *COST 
STlT— SINT1 *SINT 
SC1T-SINT1 *COST 
CSlT-COSTl *SINT 

DO 110 IX— 1, NXD 
L-L+l 

COMPUTE POINT DIPOLE POLARIZATION VECTOR IN SPHERICAL ORTHONORMAL 
UNIT VECTORS (ER, ETHETA, EPHI ) WITH SUSCEP (L) -1 .0 

JR-Fl *SIN (II ) 

JTHETA-Fl*COS ( 11 ) *COS (Dl ) 

JPHI-Fl*COS (II) *SIN (Dl) 

COMPUTE MAGNETIC FIELD VECTOR (U,V,W) AT THE POINT (R, THETA, PHI ) 
DUE TO POINT DIPOLES AT (Rl, THETAl (JY) , PHI 1 (IX) ) 

PHI 1-XORD+ FLOAT (IX-1 } *DXD 
SINP-SIN (PHI— PHIl ) 

COSP-COS (PHI-PHI1 ) 

A-CT1T+ STlT* COS P 
B-SClT— CS1T*C0SP 
C-SINT*SINP 
R2-E-G*A 
R15-R2**1 . 5 
R25-R2**2.S 

XX-JR* (RD-RO*A)+JTHETA*KO*B-JPHI*RO*C 

ATHETA— CS1T+SC1T*C0SP 

BTHETA— ST1T-CT1T*C0SP 

CTHETA-COST* SINP 

APHI— SINT1*SINP 

BPHI -COSTl *SINP 

CPHI-COSP 

Ul— JR*A+JTHETA*B-JPHI*C 
U2 — 3 . 0*XX* (RO-RD*A) 

U3-U1/R1 5 
U4-U2/R25 
U-U3+U4 

Vl — JR*ATHETA+ JTHETA*BTHETA- JPH I * CTHETA 

V2-3 . 0*XX* RD*ATHETA 

V3-V1/R15 

V4-V2/R25 

V-V3+V4 

W1 — JR*APHI + JTHETA*BPHI- JPHI *CPHI 

W2-3. 0*XX*RD*APHI 

W3-W1/R15 

W4-W2/R25 

W-W3+W4 

CALCULATE THE COMPONENT OF THE ANOMALOUS FIELD IN THE DIRECTION 

OF THE GEOMAGNETIC FIELD AT THE OBVSERVATION POINT I.E., 

( (U,V,W)* (UR,UTHETA,UPHI))*P(L) - TOTAL MAGNETIC FIELD 

UR-SIN(I) 

UTHETA-COS (I > *COS (D) 

UPHI-COS (I ) *SIN (D) 

TMAG (L) -UR*U+UTHETA*V+UPHI*W 
YC-YC+P (L) *TMAG (L) 

110 CONTINUE 

RETURN 

END 

SUBROUTINE GEOMAG (YEAR, ELV, THETA, PHI , HTHETA, HPHI, NTHETA, NPHI , NF) 
real fldd, f ldo, incd, inco, deed, deco 

dimension f ldd (44 , 181) , fldo (44, 361 ) , incd (44 , 181) , inco (44, 361 ) , 

> deed (4 4, 181 ), deco (44 , 361 ) 

common /gmf/ fldd, fldo, Incd, inco, deed, deco 


************************** *********************************** 
THIS SUBROUTINE CALCULATES THE MAGNITUDE, INCLINATION, AND 
DECLINATION OF THE GEOMAGNETIC FIELD ON A GRID NTHETA BY 
NPHI 

******************************** ***************************** 
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THETA, PHI ** 
ELV ** 
HTHETA, HPHI ** 
NTHETA, NPHI ** 
NF ** 


ORIGIN OF THE GRID (DEG.) 

ELEVATION OF GRID (KILO. ABOVE SEA LEVEL) 
GRID SPACING (DEG.) 

DIMENSIONS OF THE GRID 

UNIT FILE WHICH WILL STORE THE FIELD 


************************************************************* 
SUBROUTINES USED 

** FIELDG ** (NASA) 

** FIELD ** (NASA) 

** WRITEB ** (SYSTEM) 

************************************************************* 


REAL F(361) , INC (361 ) , DEC ( 361 ) 

C 

write (6,*) * ' 
if (nf .eq. 10) then 

write (6,*) 'the following is the geomagnetic field' 
write (6,*) 'over the observation grid* 
elseif (nf .eq. 11) then 

write (6,*) 'the following is the geomagnetic field' 
write (6,*) 'over the source grid' 
endlf 

write (6,*) ' * 
c 

LL-0 

YYYYYY-THETA 

XXXXXX-PHI 

C 

DO 120 I -1, NTHETA 
PHI-XXXXXX 
DO 110 J-l , NPHI 
C 

CALL FIELDG (THETA, PHI , ELV, YEAR, 50, LL, X, Y, Z, F (J) ) 
C 

H-SQRT (X**2+Y**2) 

INC ( J) -ATAN2 (Z, H) 

DEC ( J) -ATAN2 (Y,X) 

PHI-PHI+HPHI 


110 CONTINUE 
C 

c change 6 to nf in write statement 

c if separate files for g.m.f.o.o. 

c and g.m.f.o.s is wanted, don't forget 

c to also use open statements. 


WRITE (6,9981) (F (L) , L-l , NPHI ) 

WRITE (6, 9981) (INC (L) , L-l, NPHI > 

WRITE (6, 9981) (DEC (L) , L-l, NPHI > 

write (67, 9901) (f (1) , 1-1, nphi) 

write (60, 9981) ( (inc (1) *57 . 295828) , 1-1 , nphi } 

write (69, 9981) ( (dec (1) *57 . 295828) , 1-1 , nphi ) 

9981 format (4 (lx, f 19. 9) ) 

C 

if (nf .eq. 11) then 
do 710 1-1, nphi 
f ldd (i, 1 ) -f (1 ) 
incd(i,l) -inc(l) 
deed (i, 1) -dec (1) 

710 continue 

else if (nf .eq. 10) then 
do 720 1-1, nphi 
f ldo (i, 1) -f (1) 
inco (i,l)-inc(l) 
deco (i, 1 ) -dec (1) 

720 continue 

endif 

TH ETA -THETA+ HTHETA 
120 CONTINUE 
C 

PHI-XXXXXX 

THETA-YYYYYY 

RETURN 

C 

END 

SUBROUTINE FIELDG (DLAT, DLONG, ALT, TM, NMX, L, X, Y, Z, F) 

C 

C 

c ************************************************************** 

C FOR DOCUMENTATION OF THIS SUBROUTINE AND SUBROUTINE FIELD SEE 

C NATIONAL SPACE SCIENCE DATA CENTER*S PUBLICATION 

C * *COMPUTATION OF THE MAIN GEOMAGNETIC FIELD 

C FROM SPHERICAL HARMONIC EXPANSIONS** 

C DATA USERS' NOTE, NSSDC 68-11, MAY 1968 

C GODDARD SPACE FLIGHT CENTER, GREENBELT, MD. 

C ************************************************************** 

C 

C DLAT ** LATITUDE IN DEGREES POSITIVE NORTH 
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DLONG ** LONGITUDE IN DEGREES POSITIVE EAST 

ALT ** ELEVATION IN KM (POSITIVE ABOVE, NEGATIVE BELOW 
EARTH'S SURFACE) 

TM ** EPOCH IN YEARS 

NMX ** SET TO INTEGER GREATER THAN DEGREE OF EXPANSION 

L ** SET TO 1 ON INITIAL DUMMY CALL, SET TO 0 ON SUBSEQUENT 
CALLS 

SUBROUTINE RETURNS GEOMAGNETIC FIELD DIRECTIONS <X,Y,Z), POSI- 
TIVE NORTH, EAST AND DOWN, RESPECTIVELY, AND MAGNITUDE OF TOTAL 
FIELD, F ALL VALUES ARE IN GANMAS 


C 

C 

c 


EQUIVALENCE (SHMIT (1 , 1 ) , TG (1 , 1 ) ) 

COMMON /NASA/ TG(55,55) 

COMMON /FLDCCM/ CPH, SPH, R, CT, ST, BT, BP, BR, B 
COMMON /MAX/ NMAX 

DIMENSION G (55, 55) , GT(55, 55), SHMIT (55, 55) , AID(55), GTT(55,55) 
DATA A/0./ 

TLAST-0.0 

IF (A. EQ. 6378. 16) IF(L) 210,100,110 


A-6378.16 

FLAT-1. -1./298. 25 

A2-A**2 

A4-A**4 

B2-(A*FLAT)**2 

A2B2-A2* (1 . -FLAT**2) 

A4B4-A4* (1. -FLAT** 4) 

IF (L) 160,160,110 
100 IF (TM-TLAST) 190,210,190 
110 READ (3, 260) J,K, TZERO, (AID(I) , 1-1,11) 

L-0 

c WRITE (6, 270) J, K, TZERO, (AID (I ) , 1-1 , 1 1 ) 

MAXN-0 

TEMP-0. 

120 READ (3,280) N, M, GNM, HNM, GTNM, HTNM, GTTNM, HTTNM 
IF (N.LE.0) GO TO 130 
MAXN- (MAX0 (N, MAXN) ) 

G (N, M) -GNM 
GT (N, M) -GTNM 
GTT (N,M) -GTThM 
TEMP-AMAX1 (TEMP, ABS (GTNM) ) 

IF (M.EQ.l) GO TO 120 
G (M-l , N) -HNM 
GT (M-l, N) -HTNM 
GTT (M-l , N) -HTTNM 
GO TO 120 
130 continue 
rewind (3) 
c 130 WRITE (6,290) 
c DO 150 N-2 , MAXN 

c DO 150 M-l , N 

c MI -M-l 

c IF (M.EQ.l) GO TO 140 

C WRITE (6, 300) N, M, G (N,M) , G (MI, N) , GT (N,M) , GT (MI, N) ,GTT (N, M) , GTT ( 

c 1 MI, N) 

C GO TO 150 

c 140 WRITE (6, 310) N,M, G (N,M) ,GT (N,M) , GTT (N,M) 

C 150 CONTINUE 

WRITE (6,320) 

IF (TEMP . EQ. 0 . ) L— 1 
160 IF (K.NE.0) GO TO 190 
SHMIT (1, 1 ) — 1. 

DO 170 N-2, MAXN 

SHMIT (N, 1 ) -SHMIT (N— 1 , 1 ) * FLOAT (2*N-3) /FLOAT (N-l) 

SHMIT (l,N)-0. 

JJ-2 

DO 170 M-2,N 

SHMIT (N,M> -SHMIT (N, M-l ) *SQRT (FLOAT ( (N-M+l) * JJ) /FLOAT (N+M-2) > 
SHMIT (M-l , N) -SHMIT (N, M) 

170 JJ-1 

DO 180 N-2, MAXN 
DO 180 M-l , N 

G (N, M) -G (N, M) *SHMIT (N,M) 

GT (N, M) -GT (N, M) * SHMIT ( N, M) 

GTT (N, M) -GTT (N,M) *SHMIT (N,M) 

IF (M.EQ.l) GO TO 180 
G (M-l , N) -G (M-l , N) *SHMIT (M-l , N) 

GT (M-l , N) -GT (M-l, N) * SHMIT (M-l, N) 

GTT (M-l, N> -GTT (M-l, N) * SHMIT (M-l, N) 

180 CONTINUE 
190 T-TM-TZERO 

DO 200 N-l, MAXN 
DO 200 M-l, N 

TG (N, M) -G (N, M) +T* (GT (N, M) +GTT (N, M) *T) 

IF (M.EQ.l) GO TO 200 

TG (M-l , N ) -G (M-l , N) +T* (GT (M-l , N) +GTT (M-l , N) *T) 
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200 CONTINUE 
TLAST-TM 

210 DLATR-DLAT/57.295779S 
SINLA-SIN (DLATR) 

RLONG-DLONG/57. 2957795 
CPH-COS (RLONG) 

SPH-SIN(RLONG) 

IF (J.EQ.O) GO TO 220 
R-ALT+6371.0 
CT-SINIA 
GO TO 230 

220 SINLA2-SINLA**2 
C0SLA2-1 .-SINLA2 
DEN2-A2-A2B2*SINLA2 
DEN-SQRT (DEN2 ) 

FAC- ( ( <ALT*DEN) +A2 > / ( (ALT*DEN) +B2 ) ) * * 2 
CT-SINLA/SQRT(FAC*COSLA2+SINLA2) 

R-SQRT (ALT* (ALT+2 . *DEN) + (A4-A4B4*SINLA2) /DEN2) 

230 ST-SQRT ( 1 . -CT* * 2 ) 

NMAX -MI NO (NMX,MAXN) 

c 

CALL FIELD 
C 

Y-BP 

F-B 

IF (J) 240, 250, 240 
240 X— BT 
Z— BR 
RETURN 
C 

C TRANSFORMS FIEID TO GEODETIC DIRECTIONS 

C 

250 SIND- SI NLA* ST-SQRT (COS LA 2 ) *CT 
COSD-SQRT (1 .0-SIND**2) 

X— BT*COSD-BR*SIND 
2-BT* SIND-BR*COSD 
RETURN 
C 

260 FORMAT (211 , IX, F6. 1 , 10A6, A3) 

270 FORMAT (213, 5X, 6HEPOCH , F7 .1 , 5X, 10A6, A3) 

280 FORMAT (2I3,6F11.4) 

290 FORMAT (6H0 N M, 6X, 1HG, 10X, 1HH, 9X, 2HGT, 9X, 2HHT, 8X, 3HGTT, 8X, 3HHTT/ / 
1} 

300 FORMAT (213, 6F11.4) 

310 FORMAT (213, Fll . 4, 11X, Fll .4, 11X, Fll .4 ) 

320 FORMAT (///) 

C 

END 

C 

C 

SUBROUTINE FIELD 
C 

CONWON /NASA/ G(55,55) 

COMMON /FLDCCM/ CPH, SPH, R, CT, ST, BT, BP, BR, B 
COMMON /MAX/ NMAX 

DIMENSION P (55, 55) , DP(55,55), CONST (55, 55) , SP(55), CP(55), 

> FN (55) , FM (55) 

DATA P{l,l)/0./ 

C 

IF (P(l, 1) .EQ.1.0) GO TO 120 
P(l,l)-1. 

DP (1,1) -0. 

SP (1 ) -0. 

CP <1)-1 . 

DO 110 N-2,18 
FN (N) -N 
DO 110 M-l, N 
FM (M) -M-l 

110 CONST (N,M) -FLOAT ( (N-2) **2- (M-l) **2 ) /FLOAT ( (2*N-3) * <2*N-5) ) 

120 SP (2 ) -SPH 
CP (2 ) -CPH 
DO 130 M-3, NMAX 

SP (M) -SP (2) *CP (M-1)+CP (2 ) *SP (M-l) 

1 30 CP (M) -CP (2) *CP (M-l) -SP (2) *SP (M-l ) 

AOR-6371 ,0/R 

AR-AOR**2 

BT-0. 

BP-0. 

BR-0. 

DO 190 N-2, NMAX 
AR-AOR*AR 
DO 190 M-l, N 

IF (N-M) 150,140,150 
140 P (N, N) -ST*P (N-l , N-l ) 

DP (N, N) -ST*DP (N-l , N-l ) +CT*P (N-l, N-l) 

GO TO 160 

150 P(N,M)-CT*P (N-l, M) -CONST (N,M)*P (N-2,M) 

DP <N,M) -CT*DP (N-l ,M) -ST*P (N-l ,M) -CONST (N,M) *DP (N-2,M) 

160 PAR-P (N,M> *AR 

IF (M.EQ.l) GO TO 170 
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170 


C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


TEMP-G (N,M) *CP (M) +G (M-l, N) *SP <M) 

BP-BP- (G (N, M) * SP <M) -G (M-l , N) *CP (M) ) *FM (M) * PAR 
GO TO 180 
TEMP-G (N,M) *CP(M) 

BP-BP- (G (N, M) * SP (M) ) * FM (M) * PAR 
180 BT-BT+TEMP*DP (N,M) *AR 
190 BR-BR-TEMP*FN(N)*PAR 
BP-BP/ST 

B-SQRT (BT*BT+BP* BP+ BR* BR) 

RETURN 


END 

SUBROUTINE SPPCO (AP, N, RCOND, Z, INFO) 

INTEGER N, INFO 
REAL AP (1 ) , Z (1 ) 

REAL RCOND 

SPPCO FACTORS A REAL SYMMETRIC POSITIVE DEFINITE MATRIX 
STORED IN PACKED FORM 

AND ESTIMATES THE CONDITION OF THE MATRIX. 

IF RCOND IS NOT NEEDED, SPPFA IS SLIGHTLY FASTER. 

TO SOLVE A*X - B , FOLLOW SPPCO BY SPPSL. 

TO COMPUTE INVERSE (A) *C , FOLLOW SPPCO BY SPPSL. 

TO COMPUTE DETERMINANT (A) , FOLLOW SPPCO BY SPPDI. 

TO COMPUTE INVERSE (A) , FOLLOW SPPCO BY SPPDI. 

ON ENTRY 


AP REAL (N*(N+l)/2) 

THE PACKED FORM OF A SYMMETRIC MATRIX A . THE 
COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY 
IN A ONE-DIMENSIONAL ARRAY OF LENGTH NMN+D/2 . 

SEE COMMENTS BELOW FOR DETAILS. 

N INTEGER 

THE ORDER OF THE MATRIX A . 

ON RETURN 

AP AN UPPER TRIANGULAR MATRIX R , STORED IN PACKED 

FORM, SO THAT A - TRANS (R)*R . 

IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. 
RCOND REAL 

AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . 

FOR THE SYSTEM A*X - B , RELATIVE PERTURBATIONS 
IN A AND B OF SIZE EPSILON MAY CAUSE 
RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND 
IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION 
1.0 + RCOND .EQ. 1.0 

IS TRUE, THEN A MAY BE SINGULAR TO WORKING 
PRECISION. IN PARTICULAR, RCOND IS ZERO IF 
EXACT SINGULARITY IS DETECTED OR THE ESTIMATE 
UNDERFLOWS. IF INFO .NE. 0 , RCOND IS UNCHANGED. 

Z REAL (N) 

A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. 
IF A IS SINGULAR TO WORKING PRECISION, THEN Z IS* 
AN APPROXIMATE NULL VECTOR IN THE SENSE THAT 
NORM (A*Z) - RCOND*NORM(A) *NORM(Z) . 

IF INFO .NE. 0 , Z IS UNCHANGED. 

INFO INTEGER 

- 0 FOR NORMAL RETURN. 

- K SIGNALS AN ERROR CONDITION. THE LEADING MINOR 

OF ORDER K IS NOT POSITIVE DEFINITE. 

PACKED STORAGE 

THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER 
TRIANGLE OF A SYMMETRIC MATRIX. 

K - 0 

DO 20 J - 1, N 
DO 10 I - 1, J 
K - K + 1 
AP (K) - A (I, J) 

10 CONTINUE 
20 CONTINUE 

LINPACK. THIS VERSION DATED 08/14/78 . 

CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. 
SUBROUTINES AND FUNCTIONS 
LINPACK SPPFA 

BLAS SAXPY, SDOT, SSCAL, SASUM 
FORTRAN ABS, AMAX1 , REAL, SIGN 

INTERNAL VARIABLES 
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c 

REAL SDOT, EK, T, WK, WKM 
REAL ANORM, S, SASUM, SM, YNORM 
INTEGER I, I J, J, JMl, Jl, K, KB, KJ, KK, KP1 
C 
C 

C FIND NORM OF A 
C 

J1 - 1 

DO 30 J - 1, N 

Z{J) - SASUM (J,AP(Jl),l) 

IJ - J1 
Jl - Jl 4 J 
JMl - J - 1 

IF (JMl .LT. 1) GO TO 20 
DO 10 I - 1, JMl 

Z ( I ) - Z (I ) + ABS (AP (I J) ) 

IJ - IJ 4 1 
10 CONTINUE 

20 CONTINUE 

30 CONTINUE 

ANORM - 0.0E0 
DO 40 J - 1, N 

ANORM - AMAX1 (ANORM, Z ( J} ) 

40 CONTINUE 
C 

C FACTOR 

C 

CALL SPPFA (AP,N, INFO) 

IF (INFO .NE. 0) GO TO 180 
C 

C RCOND - 1/ (NORM (A)* (ESTIMATE OF NORM ( INVERSE (A) )) ) . 

C ESTIMATE - NORM (Z) /NORM (Y) WHERE A*Z - Y AND A*Y - E . 

C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL 

C GROWTH IN THE ELEMENTS OF W WHERE TRANS (R) *W - E . 

C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. 

C 

C SOLVE TRANS (R)*W - E 

C 

EK - 1.0E0 
DO 50 J - 1, N 
Z(J) - 0.0E0 
50 CONTINUE 
KK - 0 

DO 110 K - 1, N 
KK - KK + K 

IF (Z (K) .NE. 0.0E0) EK - SIGN (EK, -Z (K) ) 

IF (ABS (EK-Z (K) ) .LE. AP (KK) ) GO TO 60 
S - AP(KK) /ABS (EK-Z (K>) 

CALL SSCAL (N, S, Z, 1) 

EK - S*EK 
60 CONTINUE 

WK - EK - Z (K) 

WKM - -EK - Z(K) 

S - ABS (WK) 

SM - ABS (WKM) 

WK - WK/AP (KK) 

WKM - WKM/AP (KK) 

KPl - K 4 1 
KJ - KK 4 K 

IF (KPl .GT. N) GO TO 100 
DO 70 J - KPl, N 

SM - SM 4 ABS (Z ( J) +WKM*AP (KJ) ) 

Z(J) - Z(J) 4 WK*AP (KJ) 

S - S 4 ABS (Z (J) ) 

KJ - KJ 4 J 
70 CONTINUE 

IF (S .GE. SM) GO TO 90 
T - WKM - WK 
WK - WKM 
KJ - KK 4 K 

DO 80 J - KPl, N 

Z(J) - Z(J) 4 T*AP (KJ) 

KJ - KJ 4 J 

80 CONTINUE 

90 CONTINUE 

100 CONTINUE 

Z(K) - WK 

110 CONTINUE 

S - 1 . 0E0/ SASUM (N, Z , 1 ) 

CALL SSCAL (N,S,Z,1) 

C 

C SOLVE R*Y - W 

C 

DO 130 KB - 1, N 
K - N 4 1 - KB 

IF (ABS (Z (K) ) .LE. AP (KK) ) GO TO 120 
S - AP (KK) /ABS (Z (K) ) 

CALL SSCAL (N, S, Z,l) 

120 CONTINUE 
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Z(K) - Z(K)/AP(KK) 

KK - KK - K 
T - -Z(K) 

CALL SAXPY (K-1,T, AP (KK+1 ),1,Z(1),1) 

130 CONTINUE 

S - 1 . QEO/SASLM (N, Z # 1 ) 

CALL SSCAL(N, S,Z,1) 

YNORM - 1.0E0 

SOLVE TRANS (R) *V - Y 

DO 150 K - 1, N 

Z (K > - Z(K) - SDOT(K-l,AP<KK+l) # l,Z(l),l) 

KK - KK + K 

IF (ABS (Z (K) ) .LE. AP{KK) ) GO TO 140 
S - AP (KK) /ABS (Z (K) ) 

CALL SSCAL (N, S, Z, 1) 

YNORM - S* YNORM 
140 CONTINUE 

Z(K) - Z (K) /AP (KK) 

150 CONTINUE 

S - 1 . 0E0/ SASUM (N, Z, 1 } 

CALL SSCAL (N, S, Z, 1 ) 

YNORM - S* YNORM 

SOLVE R*Z - V 

DO 170 KB - 1, N 
K - N + 1 - KB 

IF (ABS (Z (K) } .LE. AP(KK>) GO TO 160 
S - AP (KK) /ABS (Z (K) ) 

CALL SSCAL (N, S,Z,1) 

YNORM - S* YNORM 
160 CONTINUE 

Z(K) - Z (K) /AP (KK) 

KK - KK - K 
T - — Z (K) 

CALL SAXPY (K-l ,T, AP (KK+1 ) , 1, Z (1 ) , 1 ) 

170 CONTINUE 

MAKE ZNORM - 1.0 
S - 1.0E0/SASUM(N, Z, 1 ) 

CALL SSCAL (N, S, Z,l) 

YNORM - S* YNORM 

IF (ANORM .NE. O.0E0) RCOND - YNORM/ ANORM 
IF (ANORM .EQ. O.0E0) RCOND - 0.0E0 
180 CONTINUE 
RETURN 
END 

SUBROUTINE SPPFA (AP , N, INFO) 

INTEGER N, INFO 
REAL AP (1 ) 

SPPFA FACTORS A REAL SYMMETRIC POSITIVE DEFINITE MATRIX 
STORED IN PACKED FORM. 

SPPFA IS USUALLY CALLED BY SPPCO, BUT IT CAN BE CALLED 
DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED 
(TIME FOR SPPCO) - (1 + 18/NJMTIME FOR SPPFA) . 


ON ENTRY 


ON RETURN 


REAL (N*(N+l)/2) 

THE PACKED FORM OF A SYMMETRIC MATRIX A . THE 
COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY 
IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+l)/2 
SEE COMMENTS BELOW FOR DETAILS. 

INTEGER 

THE ORDER OF THE MATRIX A . 


AN UPPER TRIANGULAR MATRIX R , STORED IN PACKED 
FORM, SO THAT A - TRANS (R)*R . 

INTEGER 

- 0 FOR NORMAL RETURN. 

- K IF THE LEADING MINOR OF ORDER K IS NOT 

POSITIVE DEFINITE. 


PACKED STORAGE 

THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER 
TRIANGLE OF A SYMMETRIC MATRIX. 

K - 0 

DO 20 J - 1, N 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 
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c 

c 
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c 

c- 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


DO 10 I - 1, J 
K « K + 1 
AP(K) - A(I,J) 

10 CONTINUE 
20 CONTINUE 

LINPACK. THIS VERSION DATED 08/14/70 . 

CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. 

SUBROUTINES AND FUNCTIONS 

BLAS SDOT 
FORTRAN SQRT 

INTERNAL VARIABLES 

REAL SDOT, T 
REAL S 

INTEGER J, JJ, JMl , K, KJ, KK 
BEGIN BLOCK WITH ...EXITS TO 40 


JJ - 0 

DO 30 J - 1, N 
INFO - J 
S - O.OEO 
JMl - J - 1 
KJ - JJ 
KK - 0 

IF (JMl .LT. 1) GO TO 20 
DO 10 K - 1, JMl 
KJ - KJ + 1 

T - AP (KJ) - SDOT (K-l, AP (KK+1 ) , 1, AP ( JJ+1 ) , 1 ) 
KK ■ KK ♦ K 
T - T/AP (KK) 

AP (KJ) - T 
S - S + T*T 
10 CONTINUE 

20 CONTINUE 

JJ - JJ + J 
S - AP ( JJ) - S 
EXIT 

IF (S . LE. 0.0E0) GO TO 40 
AP ( JJ) - SQRT (S) 

30 CONTINUE 
INFO - 0 
40 CONTINUE 
RETURN 
END 

SUBROUTINE SAXPY (N, SA, SX, INCX, SY , INCY ) 


COMPUTER 


- CDC/SINGLE 


LATEST REVISION - JANUARY 1, 1978 

PURPOSE - COMPUTE A CONSTANT TIMES A VECTOR PLUS 

A VECTOR, ALL SINGLE PRECISION 


USAGE 


- CALL SAXPY <N, SA, SX, INCX, SY, INCY) 


ARGUMENTS 


N - LENGTH OF VECTORS X AND Y. (INPUT) 

SA - REAL SCALAR. (INPUT) 

SX - REAL VECTOR OF LENGTH MAX (N*IABS (INCX) , 1 ) . 
(INPUT) 

INCX - DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT) 
X(I) IS DEFINED TO BE.. 

SX(1+ (1-1) *INCX) IF INCX.GE .0 OR 
SX (1+(I-N)*I NCX ) IF INCX.LT.0. 

SY - REAL VECTOR OF LENGTH MAX (N*IABS (INCY) , 1 > . 

(INPUT/OUTPUT) 

SAXPY REPLACES Y(I) WITH SA*X(I)+Y(I) 

FOR 1-1, . . ,,N. 

X<I) AND Y (I ) REFER TO SPECIFIC ELEMENTS 
OF SX AND SY, RESPECTIVELY. SEE INCX AND 
INCY ARGUMENT DESCRIPTIONS. 

INCY - DISPLACEMENT BETWEEN ELEMENTS OF SY. (INPUT) 
Y (I ) IS DEFINED TO BE.. 

SY ( 1 + ( I -1 ) * I NCY ) IF INCY .GE .0 OR 
SY ( 1 + ( I -N ) * I NCY ) IF INCY.LT.0. 


PRECISION/HARDWARE - SINGLE/ALL 


REQD. IMSL ROUTINES - NONE REQUIRED 

NOTATION - INFORMATION ON SPECIAL NOTATION AND 

CONVENTIONS IS AVAILABLE IN THE MANUAL 
INTRODUCTION OR THROUGH IMSL ROUTINE UHELP 
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- 1978 BY IMSL, INC. ALL RIGHTS RESERVED. 


COPYRIGHT 

WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN 

APPLIED TO THIS CODE. NO OTHER WARRANTY, 
EXPRESSED OR IMPLIED, IS APPLICABLE. 


SPECIFICATIONS FOR ARGUMENTS 
INTEGER N, INCX, INCY 

REAL SX(1),SY(1),SA 

SPECIFICATIONS FOR LOCAL VARIABLES 
INTEGER I, IX, IY,M,MP1,NS 

FIRST EXECUTABLE STATEMENT 
IF (N. LE. O.OR.SA. EQ. 0. EO) RETURN 
IF ( INCX. EQ. INCY) IF <INCX-1) 5,15,35 
5 CONTINUE 

CODE FOR NONEQUAL OR NONPOSITIVE 
INCREMENTS. 

IX - 1 
IY - 1 

IF (INCX.LT.O) IX - <-N+l)*INCX+l 
IF (INCY.LT.O) IY - (-N+1 ) *INCY+1 
DO 10 I-1,N 

SY(IY) - SY (IY)+SA*SX (IX) 

IX - IX+INCX 
IY - IY+INCY 
10 CONTINUE 
RETURN 

CODE FOR BOTH INCREMENTS EQUAL TO 1 
CLEAN-UP LOOP SO REMAINING VECTOR 
LENGTH IS A MULTIPLE OF 4. 

15 M - N- (N/4 ) *4 

IF (M.EQ.O) GO TO 25 
DO 20 I-1,M 

SY (I) - SY { I } +SA*SX (I ) 

20 CONTINUE 

IF (N.LT.4) RETURN 
25 MP1 - M+l 

DO 30 I-MPl, N, 4 

SY (I ) - SY (I ) +SA*SX {I ) 

SY(I + 1) - SY(I+1)+SA*SX(I+1) 

SY {1+2 ) - SY (1+2 } +SA*SX (1+2 ) 

SY (1+3) - SY (1+3) +SA*SX (1 + 3) 

30 CONTINUE 
RETURN 

CODE FOR EQUAL, POSITIVE, NONUNIT 
INCREMENTS. 

35 CONTINUE 
NS - N*INCX 
DO 40 1-1, NS, INCX 

SY (I) - SA*SX (I ) +SY ( I ) 

40 CONTINUE 
RETURN 
END 

REAL FUNCTION SDOT (N, SX, INCX, SY, INCY ) 


COMPUTER 


CDC/SINGLE 


LATEST REVISION 

PURPOSE 

USAGE 

ARGUMENTS SDOT 

N 

SX 

INCX 

SY 

INCY 


PRECISION/ HARDWARE 


JANUARY 1, 1978 

COMPUTE SINGLE PRECISION DOT PRODUCT 

FUNCTION SDOT (N, SX, INCX, SY, INCY) 

SUM FROM 1-1 TO N OF X(I)*Y(I). (OUTPUT) 

X (I > AND Y (I ) REFER TO SPECIFIC ELEMENTS 
OF SX AND SY, RESPECTIVELY. SEE INCX AND 
INCY ARGUMENT DESCRIPTIONS. 

LENGTH OF VECTORS X AND Y. (INPUT) 

REAL VECTOR OF LENGTH MAX (N*IABS (INCX) , 1 ) . 
(INPUT) 

DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT) 
X(I) IS DEFINED TO BE.. 

SX(1+(I— 1)*I NCX ) IF INCX.GE.O OR 
SX (1+ (I-N) *INCX) IF INCX.LT.O. 

REAL VECTOR OF LENGTH MAX (N*IABS (INCY) , 1 ) . 
(INPUT) 

DISPLACEMENT BETWEEN ELEMENTS OF SY. (INPUT) 
Y (I) IS DEFINED TO BE. . 

SY(1+(I-1)*INCY) IF INCY.GE.O OR 
SY(1+(I— N)*I NCY ) IF INCY.LT.O. 

SINGLE/ALL 


REQD. IMSL ROUTINES - NONE REQUIRED 
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NOTATION - INFORMATION ON SPECIAL NOTATION AND 

CONVENTIONS IS AVAILABLE IN THE MANUAL 
INTRODUCTION OR THROUGH IMSL ROUTINE UHELP 

COPYRIGHT - 1978 BY IMSL, INC. ALL RIGHTS RESERVED. 


WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN 

APPLIED TO THIS CODE. NO OTHER WARRANTY, 
EXPRESSED OR IMPLIED, IS APPLICABLE. 


SPECIFICATIONS FOR ARGUMENTS 
INTEGER N, INCX, INCY 

REAL SX ( 1 ) , SY ( 1 ) 

SPECIFICATIONS FOR LOCAL VARIABLES 
INTEGER I,M,MP1,NS, IX, IY 

FIRST EXECUTABLE STATEMENT 

SDOT - 0.0E0 
IF (N.LE.O) RETURN 

IF (INCX. EQ. INCY) IF (INCX-l) 5,15,35 
5 CONTINUE 

CODE FOR UNEQUAL INCREMENTS OR 
NONPOSITIVE INCREMENTS. 

IX - 1 
IY - 1 

IF (INCX.LT.O) IX - (-N+1 ) * INCX +1 
IF (INCY.LT.O) IY - (-N+1 ) *INCY+1 
DO 10 I«1,N 

SDOT - SDOT+SX (IX) *SY (IY) 

IX - IX+INCX 
IY - IY+INCY 
10 CONTINUE 
RETURN 

CODE FOR BOTH INCREMENTS EQUAL TO 1 
CLEAN-UP LOOP SO REMAINING VECTOR 
LENGTH IS A MULTIPLE OF 5. 

15 M - N- (N/5) *5 

IF (M.EQ.O) GO TO 25 
DO 20 I-1,M 

SDOT - SDOT+SX (I ) *SY (I ) 

20 CONTINUE 

IF (N.LT.5) RETURN 
25 MPl - M+l 

DO 30 I -MPl , N, 5 

SDOT - SDOT+SX (I) *SY (I)+SX(I+1) *SY (I+l)+SX(I+2)*SY(I+2)+SX(I 
1 +3) *SY (1+3) +SX (I+4) # SY(I + 4) 

30 CONTINUE 
RETURN 

CODE FOR POSITIVE EQUAL INCREMENTS 
.NE.l. 

35 CONTINUE 
NS - N* INCX 
DO 40 1-1, NS, INCX 

SDOT - SDOT+SX (I } *SY (I) 

40 CONTINUE 
RETURN 
END 

SUBROUTINE SSCAL (N, SA, SX, INCX) 


COMPUTER 
LATEST REVISION 
PURPOSE 


- C DC/SINGLE 

- JANUARY 1, 1978 

- COMPUTE A SINGLE PRECISION CONSTANT 

TIMES A SINGLE PRECISION VECTOR 


USAGE 


CALL SSCAL (N, SA, SX, INCX ) 


ARGUMENTS N 
SA 
SX 


INCX 


LENGTH OF VECTOR X. (INPUT) 

REAL SCALAR. (INPUT) 

REAL VECTOR OF LENGTH N*INCX. (INPUT/ OUTPUT) 
SSCAL REPLACES X(I) WITH SA*X(I) FOR 
1-1, . . .,N. 

X (I ) REFERS TO A SPECIFIC ELEMENT OF SX. 
SEE INCX ARGUMENT DESCRIPTION. 

DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT) 
X(I) IS DEFINED TO BE SX (1+ (1-1) *INCX) . 
INCX MUST BE GREATER THAN ZERO. 


PRECISION/ HARDWARE - SINGLE/ALL 


REQD . IMSL ROUTINES - NONE REQUIRED 

NOTATION - INFORMATION ON SPECIAL NOTATION AND 

CONVENTIONS IS AVAILABLE IN THE MANUAL 
INTRODUCTION OR THROUGH IMSL ROUTINE UHELP 
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COPYRIGHT - 1978 BY IMSL, INC. ALL RIGHTS RESERVED. 

WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN 

APPLIED TO THIS CODE. NO OTHER WARRANTY, 
EXPRESSED OR IMPLIED, IS APPLICABLE. 


SPECIFICATIONS FOR ARGUMENTS 

INTEGER INCX, N 

REAL SA, SX (1) 

SPECIFICATIONS FOR LOCAL VARIABLES 

INTEGER I,M,MPl, NS 

FIRST EXECUTABLE STATEMENT 

IF (N.LE.O) RETURN 
IF (INCX.EQ. 1) GO TO 10 

CODE FOR INCREMENTS NOT EQUAL TO 1. 

NS - N* INCX 
DO 5 I-1,NS, INCX 
SX(I) - SA*SX (I) 

5 CONTINUE 
RETURN 

CODE FOE INCREMENTS EQUAL TO 1. 
CLEAN-UP LOOP SO REMAINING VECTOR 
LENGTH IS A MULTIPLE OF 5. 

10 M - N- (N/5) *5 

IF (M.EQ.O) GO TO 20 
DO 15 I-1,M 

SX(I) - SA*SX (I > 

15 CONTINUE 

IF (N.LT.5) RETURN 
20 MPl - M+ 1 

DO 25 I -MPl, N, 5 

SX(I) - SA*SX (I ) 

SXU + l) - SA* SX (1+1 ) 

SX (1 + 2) - SA* SX (1 + 2 ) 

SX (1+3) - SA*SX(I+3) 

SX (1 + 4) - SA*SX (1 + 4 } 

25 CONTINUE 
RETURN 
END 

REAL FUNCTION SASUM (N,SX,INCX) 


COMPUTER 
LATEST REVISION 
PURPOSE 


- CDC/SINGLE 

- JANUARY 1, 1978 

- COMPUTE SINGLE PRECISION SUM OF ABSOLUTE 

VALUES 


USAGE 


FUNCTION SASUM (N,SX,INCX) 


ARGUMENTS SASUM 


N 

SX 

INCX 


SLM FROM 1-1 TO N OF ABS(X(I)). (OUTPUT) 

X(I) REFERS TO A SPECIFIC ELEMENT OF SX. 
SEE INCX ARGUMENT DESCRIPTION. 

LENGTH OF VECTOR X. (INPUT) 

REAL VECTOR OF LENGTH N*INCX. (INPUT) 
DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT) 
X(I) IS DEFINED TO BE SX (1+ <1—1 ) *INCX) . 
INCX MUST BE GREATER THAN ZERO. 


PRECISION/ HARDWARE - SINGLE/ALL 


REQD. IMSL ROUTINES - NONE REQUIRED 

NOTATION - INFORMATION ON SPECIAL NOTATION AND 

CONVENTIONS IS AVAILABLE IN THE MANUAL 
INTRODUCTION OR THROUGH IMSL ROUTINE UHELP 

COPYRIGHT - 1978 BY IMSL, INC. ALL RIGHTS RESERVED. 

WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN 

APPLIED TO THIS CODE. NO OTHER WARRANTY, 
EXPRESSED OR IMPLIED, IS APPLICABLE. 


SPECIFICATIONS FOR ARGUMENTS 

INTEGER N, INCX 

REAL SX (1) 

SPECIFICATIONS FOR LOCAL VARIABLES 

INTEGER I,M,MP1, NS 

FIRST EXECUTABLE STATEMENT 


SASUM - O.OEO 
IF (N.LE.O) RETURN 
IF (INCX.EQ.l) GO TO 10 
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C CODE FOR INCREMENTS NOT EQUAL TO 1. 

NS - N* INCX 
DO 5 I-1,NS,INCX 

SASUM - SASUM+ABS (SX (I ) ) 

5 CONTINUE 
RETURN 

C CODE FOR INCREMENTS EQUAL TO 1. 

C CLEAN-UP LOOP SO REMAINING VECTOR 

C LENGTH IS A MULTIPLE OF 6. 

10 M - N- (N/6) *6 

IF (M.EQ.O) GO TO 20 
DO 15 I-1,M 

SASUM - SASUM+ABS (SX (I )) 

15 CONTINUE 

IF (N.LT.6) RETURN 
20 MPl - M+l 

DO 25 I-MP1,N, 6 

SASUM - SASUM+ABS (SX (I) ) +ABS (SX (1 + 1 ) ) +ABS (SX (1+2 ) ) +ABS (SX (I 
1 +3) ) +ABS {SX (1 + 4) ) +ABS (SX (1+5) ) 

25 CONTINUE 
RETURN 
END 

SUBROUTINE SPPSL (AP,N, B} 

INTEGER N 
REAL AP (1 } , B (1 ) 

C 

C SPPSL SOLVES THE REAL SYMMETRIC POSITIVE DEFINITE SYSTEM 
C A * X - B 

C USING THE FACTORS COMPUTED BY SPPCO OR SPPFA. 

C 

C ON ENTRY 

C 

C AP REAL (N*(N+l}/2) 

C THE OUTPUT FROM SPPCO OR SPPFA. 

C 

C N INTEGER 

C THE ORDER OF THE MATRIX A . 

C 

C B REAL (N) 

C THE RIGHT HAND SIDE VECTOR. 

C 

C ON RETURN 

C 

C B THE SOLUTION VECTOR X . 

C 

C ERROR CONDITION 

C 

C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS 

C A ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES 

C SINGULARITY BUT IT IS USUALLY CAUSED BY IMPROPER SUBROUTINE 

C ARGUMENTS. IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED 

C CORRECTLY AND INFO .EQ. 0 . 

C 

C TO COMPUTE INVERSE (A) * C WHERE C IS A MATRIX 

C WITH P COLUMNS 

C CALL SPPCO (AP, N, RCOND, 2, INFO) 

C IF (RCOND IS TOO SMALL .OR. INFO .NE. 0) GO TO ... 

C DO 10 J * 1, P 

C CALL SPPSL (AP , N, C (1 , J) ) 

C 10 CONTINUE 

C 

C LINPACK. THIS VERSION DATED 08/14/78 . 

C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. 

C 

C SUBROUTINES AND FUNCTIONS 

C 

C BLAS SAXPY, SDOT 

C 

C INTERNAL VARIABLES 

C 

REAL SDOT, T 
INTEGER K, KB, KK 
C 

KK - 0 

DO 10 K - 1, N 

T - SDOT (K-l, AP (KK+1) , 1 , B (1 ) , 1 ) 

KK - KK + K 

B (K) - (B (K) - T) /AP (KK) 

10 CONTINUE 

DO 20 KB - 1, N 
K - N + 1 - KB 
B { K ) - B (K) /AP (KK) 

KK - KK - K 
T - -B (K) 

CALL SAXPY (K-l ,T,AP (KK+1 ),1,B<1),1) 

20 CONTINUE 
RETURN 
END 
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0. OOOOOOOOOOOOOD+OO 
0. 1000000000000D+01 
0.2000000000000D+01 
0. 3000000000000D+01 
0. 4000000000000D+01 
0. 500000000000QD+01 
0. 6000000000000D+01 
0. 7000000000000D+01 
0. 8000000000000D+01 
0. 9000000000000D+01 
0. 1000000000000D+02 
0 . 1 100000000000D+02 
0 . 1 200000000000D+02 
0.1300000000000D+02 
0. 1400000000000D+02 
0. 1500000000000D+02 
0 . 1 600000000000D+02 
0 . 1 700000000000D+02 
0 . 1 800000000000D+02 
0 . 1 900000000000D+02 
0. 2000000000000D+02 
0. 2100000000000D+02 
0. 2200000000000D+02 
0.2300000000000D+02 
0.2400000000000D+02 
0.2500000000000D+02 
0. 2600000000000D+02 
0. 2700000000000D+02 
0 . 2 800000000000D+02 
0. 2900000000000D+02 
0. 3000000000000D+02 
0. 3100000000000D+02 
0. 3200000000000D+02 
0. 3300000000000D+02 
0. 3400000000000D+02 
0.3500000000000D+02 
0. 3600000000000D+02 
0. 3700000000000D+02 
0. 3800000000000D+02 
0. 3900000000000D+02 
0.4000000000000D+02 
0. 4 100000000000D+02 
0. 4200000000000D+02 
0. 4 300000000000D+02 
0. 4400000000000D+02 
0 . 4 500000000000D+02 
0. 4600000000000D+02 
0. 4700000000000D+02 
0. 4800000000000D+02 
0. 4 900000000000D+02 
0. 5000000000000D+02 
0.5100000000000D+02 
0. 5200000000000D+02 
0. 5300000000000D+02 
0. 5400000000000D+02 
0. 5500000000000D+02 
0. 5600000000000D+02 
0.5700000000000D+02 
0. 5800000000000D+02 
0. 5900Q00000000D+02 
0. 60QOOOOQOQOOOD+02 
0. 6100000000000D+02 
0. 6200G00000000D+02 
0. 6300000000000D+02 
0. 64Q0000000000D+02 
0.6500000000000D+02 
0. 6600000000000D+02 
0.6700000000000D+02 
0. 6800000000000D+02 
0.6900000000000D+02 
0. 7000000000000D+02 
0.7100000000000D+02 
0. 7200QQOOQOOOOD+02 
0. 7300000000000D+02 
0. 740000G0Q0000D+02 
0. 7500000000000D+02 
0. 7600000000000D+02 
0.7700000000000D+02 
0. 7800000000000D+02 
0. 79000000000000+02 
0. 8000000000000D+02 
O.01OOOOOOOOOOOD+O2 
0. 02QOOOOOQOOOOD+O2 
0. 03OOOOOOOOOOOD+O2 
0. 04OOOOOOOOOOOD+O2 
0. 8500000000000D+02 
0. 06OOOOOOOOOOOD+O2 
0.8700000000000D+02 
0.8800000000000D+02 
0. 8900000000000D+02 


0. 62 59999871 2 54 D+00 
0. 6259951659277D+00 
0. 6259807025574D+00 
0. 6259565976827D+0O 
0. 6259228524 177D+00 
0. 6258794603214D+OO 
0. 6258264473985D+00 
0. 6257637920986D+00 
0 . 625691 50531 63D+00 
0 . 6256095903911D+00 
0. 6255180511067D+00 
0.6254168916912D+00 
0. 6253061168165D+00 
0. 6251857315978D+00 
0. 6250557415938D+00 
0. 6249161520O54D+OO 
0. 62 4 76 697 167 61 D+00 
0. 6246O02O5O9O9D+OO 
0. 624 43986037 60D+00 
0 . 6242619452984D+00 
0. 624 0744 6806 50D+00 
0.62 387 74373220D+00 
0.6236708621544D+00 
0. 6234547520854D+00 
0 . 6232291 1707 52D +00 
0. 6229939675208D+00 
0.6227493142548D+00 
0.6224951685447D+00 
0 . 6222315420922D+00 
0. 6219584470318D+00 
0. 6216758959306D+00 
0. 621 3839017867D+00 
0. 6210824780285D+00 
0. 620771 63851 37D+00 
0. 620451 3 9 75281 D+00 
0. 62012 17 69784 6D+00 
0. 61 97827704219D+00 
0 . 61 943441 500 38D+00 
0 . 61907671 9517 2D+00 
0. 6187097003719D+00 
0 . 61 83333743984D+00 
0. 6179477S88472D+00 
0. 617552871 38 73D+00 
0.6171487301050D+00 
Q . 61 67353535020D+00 
0.6163127604947D+00 
0.61 58809704 124 D+00 
0.61 54 4 0002 99 56D +00 
0. 61498987839500+00 
0 . 614 53061 716 97D+0Q 
0.61406224028540+00 
0 . 61 358476911 34 D+00 
0 . 61 30982254 2 83D +00 
0.6126026314069D+00 
0. 61 209800962 62D+00 
0 . 61 1 584 38306 18D +00 
0.61 106 177 508 61 D+00 
0. 6105302094665D+00 
0 . 60 998971 036 38D +00 
0 . 60944 0302 33 01 D+00 
0.6088820103071D+00 
0 . 60831 48 596 2 4 3D +00 
0.6077388759968D+00 
0. 6071540855235D+00 
0.6065605146854D+00 
0. 6059581 903430D+00 
0 . 6053471 3973 50D+00 
0.6047273904756D+00 
0. 604 0989705528D+00 
0 . 60346190832 61 D+00 
0 . 60281 62325247D+00 
0.6021619722448D+00 
0.6014991 569479D+00 
0 . 60082781 64 583D+00 
0 . 60014 7980961 1D+00 
0.5994596809996D+00 
0 . 59876294 747 35D+00 
0.5980578116360D+00 
0 . 597 34 4 30 50 921 D+00 
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0. 4 58 OOOOOOOOOOD+03 
0. 4 5 9000000 00 00D+ 03 
0.4600000000000D+03 
0. 4 61 00000000000+03 
0.4 62 00000000000+03 
0 . 4 630000000000D+03 
0.4640000000000D+03 
0. 4650000000000D+03 
0. 4660000000000D+03 
0. 4 67 00000000000+03 
0. 4 68 OOOOOOOOOOD+03 
0 . 4 690000000000D+03 
0.4700000000000D+03 
0.4 71 00000000000+03 
0. 4720000000000D+03 
0. 4730000000000D+03 
0.4740000000000D+03 
0. 4750000000000D+03 
0. 4760000000000D+03 
0. 4770000000000D+03 
0. 4780000000000D+03 
0. 4790000000000D+03 
0. 4800000000000D+03 
0.481 OOOOOOOOOOD+03 
0. 4820000000000D+03 
0. 4830000000000D+03 
0.4 84 00000000000+03 
0. 4850000000000D+03 
0.4860000000000D+03 
0.4 87 00000000000+03 
0 . 4 880000000000D+03 
0. 4890000000000D+03 
0 . 4 900000000000D+ 0 3 
0.4 91 OOOOOOOOOOD+03 
0. 4920000000000D+03 
0 . 4 930000000000D+03 
0. 4940000000000D+03 
0. 4950000000000D+03 
0. 4960000000000D+03 
0.4970000000000D+03 
0 . 4 980000000000D+03 
0.4990000000000D+03 


0.131 6005993328D+00 
0.1306905624408D+00 
0. 1297848194604D+00 
0. 1288833604 389D+00 
0.1279862072394D+00 
0 . 1270933335422D+00 
0. 1262047448465D+00 
0. 1253204384716D+00 
0.1244404115582D+00 
0. 1235646610704D+00 
0. 122 6931 837 962D+00 
0. 1218259763500D+00 
0. 1209630351731D+00 
0.1201043565357D+00 
0.1192499365382D+00 
0. 1183997711125D+00 
0. 1175538560237D+00 
0. 1167121868713D+00 
0. 1158747590909D+00 
0. 1150415679556D+00 
0. 1142126085770D+00 
0. 1133878759075D+00 
0. 11 2 56736474 10D+00 
0. 1117510697147D+00 
0. 1109389853108D+00 
0. 1101311058574D+00 
0. 10932742 55303D+00 
0. 1085279383544D+00 
0. 1077326382055D+00 
0 . 106941 51881 11D+00 
0.1061545737523D+00 
0.1053717964654D+00 
0. 104 5931 8024 29D+00 
0. 1038187182355D+00 
0. 10304 84034532D+00 
0. 102 2822287 6 67D+00 
0. 101 5201 869094D+00 
0. 1007622 7 04 782D+00 
0. 1000084719356D+00 
0.9925878361054D-01 
0. 9851319770041D-01 
0.9777170627220D-01 
0. 9703430126409D-01 
0.9630097448686D-01 
0. 9557171762539D-01 
0. 9484652224011D-01 
0. 94 12 537 97 6844 D-01 
0.9340828152630D-01 
0. 92 69521 870950D-01 
0. 91 986182 3 9525D-01 
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APPENDIX D: STATISTICS AND DATA CONVERSIONS 


D.I CHECK 

Check is used for quickly defining the basic statistics (minimum, maximum, 
average, difference between adjacent points and variance) of an individual pass. If any one 
of the parameters is outside of the acceptable limits, then the pass number and all 
parameters are written to the screen. Rerunning this program several times while varying 
the cutoff limits helps to assess the general quality of the input data. 

D.2 STATMAT 

This program finds the standard statistics of any of the grids of Chapter III. If 
more than one grid is input, then the correlation coefficients between all possible map-to- 
map comparisons are also found. Statmat should be used to determine the similarities 
and differences between dawn and dusk maps and between continued maps. 

D.3 PART2 

This program was written by Dr. Gary P. Murdock and is used to convert the three 
Investigator-B tapes supplied by NASA on an IBM platform to a Digital Equipment 
Corporation (DEC) platform. The program converts IBM text and fixed point and floating 
point numbers to their respective representation on the DEC machine. Similar code can be 
written to convert IBM values to other platforms. 
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program check 

real*4 mean, maxval, minval, dif f,maxdif f, total, 

> maxmax,minmin,meanmax, diffmax, dummy, xmean,maxvar 
double precision passord{4000, 2 ) , ra (4000) 
character* 80 filename 

character*4 choice, test 

dimension idata (1500, 2) ,data (1500, 27) 

integer*4 count, var, countall, type, row, col, zero, pass, eight, 

> recnum, passnum (4000) , passm jd (4000, 2 ) 
common /hsort/ ra 


c- 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


program description 

check locates all passes with a minimum below a user defined 
value, a maximum above a user defined value, a variance above 
a user defined maximum, a mean value beyond a user defined value 
and a difference between adjacent observations greater than a 
user defined value, if a pass is selected, then the pass number 
and the above values are written to the screen, this program 
can be used on direct access 2i-27r files or on files with a 
header and one variable per pass, this program is used to find 
passes which are influenced by external fields as noted by 
their variance properties. 

program date: 22 apr 91 


updates: 6 jun 92; added sort subroutine 

NOTE: check now removes the checked passes (ie. the high 
variance passes) from the ordered pass number file 
written by reorder. 

NOTE: now check also orders the output file according to 
the average elevation of the pass. 

NOTE: these new options are not available for 2i-27r input. 

20 jul 92; added output file on unit 21 
NOTE: this update simplifies the useage of check 


write (*,*) '0 IF INPUT FILE IS 2I-27R* 
write {*,*) *1 IF INPUT FILE IS HEADER AND VARIABLE' 
read (*,*) type 
if (type) 50,50,200 
c 

50 write (*,*) 'INPUT 2I-27R FILE:' 
read (*,9990) filename 
9990 format (a80) 

open (10, file-filename, status- 'old' , form- ' unformatted' , 

> access-' direct* , recl-116) 

c recl-29 for a dec3100 

write (*,*) 'WHICH VARIABLE DO YOU WANT FROM THE 27' 
write (*,*) ' lat Ion rad mlt invlat diplat bs bv x y z' 
write (*,*) ’bva xa ya za totfld xfld yfld zfld inc dec' 
write (*,*) 'totmag totavgmag resid resavgmag ringcur sec' 
read (*,*) var 

write (*,*) 'MAXIMUM ABSOLUTE VALUE FOR MEAN WITHOUT TELLING YOU' 
write (*,*) 'MAXIMUM VALUE FOR DIFFERENCE' 
write (*,*) 'MAXIMUM VALUE FOR VARIABLE' 
write (*,*) 'MINIMUM VALUE FOR VARIABLE' 
write (*,*) 'MAXIMUM VARIANCE FOR VARIABLE* 
read (*,*) meanmax, dif fmax,maxmax, minmin,maxvar 
c 

write (* , * ) ' PASSNO CNT MAX MEAN MIN', 

> ' DIFF MAXVAR' 


C 

21 jstop-0 
recnum-1 
countall-0 
count-0 

read (10, rec-recnom) (idata (1,1) , i-1, 2) , (data (1, j) , j-1, 27) 

22 n-2 

23 recnum- re cnum+1 

read (10, rec-recnum, err-24 ) (idata (n, i ) , i-1 , 2) , (data (n, j) , j-1 27 ) 
if (idata (n, 1) .ne. idata (n-1, 1) ) go to 25 
n-n+1 
go to 23 

24 continue 
j stop-1 

25 continue 


countall-countall+1 

total-0. 0 

xsumsqr-0.0 

maxval— lOelO 

minval-lOelO 

maxdiff-10e-10 

dummy-data (n,var) 

data (n, var) -data (n-1, var) 

do 100 i-1, n-1 

total-total+data (l,var) 

xs urns qr-xs urns qr+ (data (1, var ) **2 ) 

maxval -max (maxval, data (i, var) ) 
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minvalmin (minval,data (1/ var) ) 
diff-data (i, var) -data (i+1, var) 
maxdif f-max (maxdlff , abs (dif f ) ) 

100 continue 

mean-total/ (n-1) 

xvar- (xsumsqr- ( ( (total) **2) /real (n-1) ) ) /real (n-2) 
absmean-abs (mean) 

if (absmean.gt .meanmax .or. maxval .gt .maxmax .or. 

> minval. lt.minmin .or. maxdif f .gt . dif fmax .or. 

> xvar.gt .maxvar) then 

write (*,9992) idata (n-1, 1 ), n-1, maxval, mean,minval, 

> maxdif f, xvar 
9992 format (2i5, 5 (lx, f 12. 6) ) 

count-count+1 

endlf 

data (n, var) -dummy 

27 continue 

do 28 i-1,2 

idata (l,i) -idata (n,i) 

28 continue 

do 29 j-1,27 

data (1, j) -data (n, j) 

29 continue 

if (jstop .eq. 1) go to 999 
go to 22 
c 

200 continue 

countall-0 

count-0 

write <*,*) 'INPUT HEADER AND ONE VARIABLE FILE:* 
read (*,9990) filename 

open (10, file-filename, stat us-' old* , form-’ unformatted' ) 
write (*,*) *1 to work with magnetic variable or latitude' 

write (*,*) '2 to work with longitude' 

write (*,*) *3 to work with radius' 

read (*,*) var 

write (*,*) 'MAXIMUM ABSOLUTE VALUE FOR MEAN WITHOUT TELLING YOU' 
write (♦,*) 'MAXIMUM VALUE FOR DIFFERENCE' 
write (*,*} 'MAXIMUM VALUE FOR VARIABLE' 
write (*,*) 'MINIMUM VALUE FOR VARIABLE' 
write (*,*) 'MAXIMUM VALUE FOR VARIANCE' 
read (*,*) meanmax, dif fmax, maxmax, mi nmin, maxvar 
write (*,*) 'REMOVE THESE PASSES FROM THE ORDERED PASS FILE' 
write (*,*) 'yes OR no (choose yes after running several times' 

write (*,*) ' to determine the variance cutoff)' 

read (*,9991) choice 
9991 format (a4) 

if (choice . eq. ' yes ' .or. choice . eq. ' YES ' ) then 

write (*,*) 'INPUT FILE OF ORDERED PASS NUMBERS' 
read (*,9990) filename 

open (11, file-filename, form- 1 formatted' , status- ' old' ) 
write (*,*) 'OUTPUT FILE - PASS NUMBERS - CHECKED NUMBERS' 
read (*,9990) filename 

open (20, file-filename, form-' formatted' ) 
icnt-0 

do i-1, 10000 

read (11,9991) test 
icnt-icnt+1 

if (test .eq. ' new') then 
read (11,9991) test 
go to 205 
end if 
end do 

205 icnt-Icnt-2 

write (*,*) 'read ',icnt,' passes from pass file* 
write (*,*) 'OUTPUT FILE OF CHECKED PASSES' 
read (*,9990) filename 

open (21, file-filename, form-' formatted' ) 
c 

do i-1, lent 

read (11,*) (passmjd(i, j) , j-1,2) , (passordU, j) , j-1, 2) 
end do 
endif 

c 

write (*,*) 'PASSNO CNT MAX MEAN MIN', 

> • DIFF MAXVAR' 

c 

210 read (10, end-500) row, col, zero, xmean, pass, eight 
do 220 i-1, row 

read (10) (data (i, j) , j-1, col) 

220 continue 

count ail -countall+1 
total-0. 0 
xsumsqr-0 . 0 
maxval— lOelO 
minval-lOelO 
maxdif f-10e-10 

data (row+1, var ) -data (row, var) 
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do 240 i-1 , row 

total-total+data (i, var) 
xsumsqr-xsumsqr* (data (1, var) **2 ) 
maxval^nax (maxval, data (i, var) ) 
minval-min (minval, data (i, var) ) 
dif f-data (1, var) -data (i+1, var) 
maxdif f-max (maxdif f , abs (diff ) ) 

240 continue 

mean-total/row 

xvar- (xsumsqr- ( ( (total) **2)/real (row) ) } /real (row-1) 
absmean-abs (mean) 

if (absmean.gt.meanmax .or. maxval .gt .maxmax .or. 

> minval.lt.minmin .or. maxdif f . gt . dif fmax .or. 

> xvar .gt .maxvar ) then 

write (*,9992) pass, row, maxval, mean, minval, maxdif f, xvar 
if (choice. eq. 'yes' .or. choice .eq. * YES ' ) 

> write (21,9992) pass, row, maxval , mean, minval, maxdif f ,xvar 

count-count+1 
passnum (count ) -pass 
endif 
go to 210 

500 continue 

if (choice. eq. * yes* .or. choice. eq. * YES 1 > then 
jcnt-0 
do i-1 , lent 

do j-1, count 

if (passm jd(i, 1) .eq. passnum(j)) go to 510 
enddo 

jent- jcnt+1 

ra ( jent ) -passord (i , 2 ) 

510 continue 

enddo 

call sort (jent) 

do i-1 , jent 
do j-l,icnt 

if ( ra(i) .eq. passord( j, 2 ) ) then 

write (20,*) (passm jd ( j, j j) , j j=l , 2) , passord< j, 1) , 

> real (passord( j, 2 ) ) 
go to 520 

endif 

enddo 

520 continue 

enddo 
endif 

999 continue 
close (10) 
close (11) 
close (20) 

write (*,*) 'total passes counted - ',countall 

write (*,*) 'total passes checked - 1 , count 

write (*,*) 'total passes written to file - *,jcnt 

stop 

end 


c 

c 


SUBROUTINE SORT (N) 
double precision ra,rra 
common /hsort/ ra(4000) 

c this subroutine is written by the autnors 

c of: Numerical Recipes (fortran); 

c The Art of Scientific Computing 

c Cambridge University Press 

c 1989, p. 230 

c the routine is referred to as "heaDsort" 

c Copyright (C) 1986, 1992 Numerical Recipes Software 
c 

L-N/2+1 
I R-N 


100 CONTINUE 

IF (L. GT. 1 ) THEN 
L-L-l 
RRA-RA(L) 

ELSE 

RRA-RA(IR) 

RA(IR)-RA(1) 

IR-IR-1 

IF (IR.EQ. 1 ) THEN 
RA < 1 ) -RRA 
RETURN 
ENDIF 
ENDIF 
I-L 
J-L + L 

200 IF ( J. LE . I R) THEN 

IF ( J. LT. IR)THEN 
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IF(RA(J) ,LT.RA(J+1) ) J-J+l 
ENDIF 

IF (RRA.LT.RA(J) ) THEN 
RA(I)-RA(J) 

I-J 

J-J+J 

ELSE 

J-IR+1 
ENDIF 
GO TO 200 
ENDIF 
RA (I ) -RRA 
GO TO 100 
END 
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program statmat 

character*70 filename (5) , statfile 

character* 5 done 

integer*4 col {5) , row (5) , count 

real* 4 nobs s, data (500, 500, 5) , colat (5) , long (5) , space (5) , 

> xmean,ymean 

dimension xdata (250000) ,ydata (250000) 
c 

program description 

c statmat defines the basic statistics of the input grids, see 
c the write statements for the specific values calculated, also, 
c the code loops through all input grids and calculates the 
c correlation coefficients between all combinations of input 
c data. 


write (*,*) 'OUTPUT STATISTICS FILE’ 
read (*,9990) statfile 

open (25, f ile-statf ile, form-' formatted' ) 
c 

c read all data into array (row, col, layer or map number) 

i-1 

10 write (*,*) ‘INPUT MATRIX WITH TPLOT HEADER* 
read (*,9990) filename (i) 

9990 format (a70) 

open (10, file-filename (i), status-' old*, form-' formatted*) 
c 

read (10, * ) col (i ) 
read (10,*) row(i) 
read (10,*) colat (i) 
read (10,*) long(i) 
read (10,*) space (i) 

read (10,*) ( (data (j,k, i) , k-1, col (i) ), j-1, row (i) ) 

close (10) 

write (*,*) ‘ARE YOU THROUGH YET???' 
read (*,9991) done 

9991 format (a5) 

if (done .eq. ' y ' .or. done .eq. 'yes') go to 50 

i-i+1 

go to 10 

c maximum number of input data sets -count 

c loops from line 80 to 400 increment through all 

c maps comparing all possible logical 

c combinations of map to map 

50 count-i 

write (*,*) 'total number of input data sets -', count 
do 60 i-1, count-1 

if (col(i) . ne . col(i-El) .or. row(I) .ne. row(i+l)) then 
write (*,*) filename (i) , col (i) , row (1 ) 
write (*,*) f ilename (i ) , col (I) , row (i ) 
write (*,*) 'rows or columns do not match* 
stop 0001 
endif 
60 continue 


from 200 to write statement of variables is 
the statistical calculations using two 
references : 

1} Davis, Statistics and Data Analysis in 
Geology, 2nd ed. , 1986 pp. 41 
2) Young, Statistical Treatment of Experi- 
mental Data, 1962, McGraw Hill, 115-132 
c 

00 continue 

do 400 icnt-1, count 

do 400 jcnt-icnt, count 
c 

do 100 j-1, row (lent) 
do 100 k-1 , col (lent) 

1 j— ( col (lent ) * ( j-1 ) ) +k 
xdata (1 j) -data ( j, k, lent ) 
ydata (i j) -data ( j, k, jent) 


100 continue 

c loops that sum x, x**2, y, y**2 and xy 


nobs-row (lent) *col (lent) 

if (nobs .ne. ij) stop 0002 

nobss-float (nobs) 

xsum-0 .0 

xsumsqr-0 .0 

y sum-0 . 0 

ysumsqr-0 . 0 

sumxy-0. 0 

xmax-xdata (1 ) 

xmin-xmax 

ym ax -ydata (1 ) 

ymin-ymax 

do 240 j4-l,nobs 

xsum-xsum+xdata ( j4 ) 
xsumsqr-xsumsqr+ (xdata ( j4 ) ) **2 
ysum-ysum+ ydata ( j4 ) 


c 

c- 

c 

c 

c 

c 

c 

c 
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ys urns qr-ys urns qr+ (ydata (J4) ) **2 
sumxy-sumxy+ (xdata( j4) *ydata { j4) ) 
xmax-max (xmax,xdata ( j4 } ) 
xmin-min (xmin,xdata ( j4) ) 
ymax-max (ymax, ydata ( j4) ) 
ymin-min (ymin,ydata (j4 ) ) 

240 continue 


c find corrected sum of products, covariance 

c and corrected sum of squares (x) (y) 

c 


xmean-x sum/nobs s 
ymean-ysum/nobss 

sumprod-sumxy- ( (xsum*ysum) /nobss) 
covarxy-sumprod/ (nobss-1 .0) 
xcsumsqr-xsumsqr- ( (xsum**2) /nobss) 
ycsumsqr-ysumsqr- ( (ysum**2) /nobss) 
c 

c find variance, standard deviation for x and y 

c 

xvar-xcsumsqr/ (nobss-1 .0) 
yvar-ycsumsqr/ (nobss-1 .0) 
xstdev-sqrt (xvar) 
ystdev-sqrt {yvar) 


c find correlation coefficient by Davis method 

corrDxy-covarxy/ (xstdev*ystdev) 

c find slopes, intercepts and correlation 

c coefficient by Young method 


xslope- ( (nobss *sumxy) -(xsum*y sum) ) / ( (nobss*xsumsqr) -xsum**2) 
yslope- ( (nobss*sumxy) -(xsum*ysum) ) / ( (nobss*ysumsqr) -ysum**2) 
xintcpt-( (ysum*xsumsqr) - (sumxy*xsum) ) / ( (nobss*xsumsqr)-xsum**2) 
yintcpt- ( (xsum*ysumsqr) - (sumxy*ysum) ) / ( (nobss*ysumsqr) -ysum**2) 
corrYxy-sqrt (xslope*yslope) 
c 

c write out this mess for individual pass and 

c overlapping lengths of passes 

c 

write (25,*) 'X - 1 , filename (icnt) 
write (25,*) * Y - 1 , filename ( jcnt ) 
write (25,9992) xmean, ymean, xvar, yvar, xstdev, ystdev 

9992 format ('X MEAN -*,f9.3, ' Y MEAN «',f9.3,/, 

> 'X VARIANCE-', f 9.1, ■ Y VARIANCE- ', f 9 . 1 , • XSTDEV-*, 

> f8 . 3, ' Y STDEV-* , f8. 3) 
write (25,9993) covarxy, corrDxy 

9993 format ('COVARIANCE XY-',f9.1,' Davis CORRELATION COEF-',f8.3) 
write (25,9994) xslope, xintcpt, y slope, yintcpt , corrYxy 

9994 format ('X SLOPE-' , f 8 . 3, * X INTERCEPT- f 8. 3, ' Y SLOPE-', 

> f8 . 3, ' Y INTERCEPT-' , f 8.3, /, 'Young CORRELATION C0EF-* 

> f8. 3, ) 

write (25, 9995) xmax , xmi n , ymax , ymi n 
write (*,*) corrDxy 

9995 format ('X-MAX-* , f9.3, * X-MIN-* , f 9. 3, ' Y-MAX-* , f9.3, 

> * Y-MIN- ' , f 9. 3, /) 
c 

c 

c increment to next set of passes 

400 continue 
c 

999 continue 
close (10) 
close (25) 
stop 
end 
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program part2 


c™ - convert magsat text from ebcdic to ascii, reorder integer bytes, 

c and translate ibm real to dec real 

c 

c editorial note: this code was supplied quite generously by Dr. Gary P. 
c Murdock 

c 

implicit none 
c 

c— — parameter storage: 
integer reclen 
parameter (reclen-3024) 
c 

c— — common storage: 

character*! ascconv(256) 
common /e2acom/ ascconv 
integer* 4 recnum, position 
common /xxyyzz/recnum, position 
c 

c— - equivalence storage: 

integer* 4 inbufi (reclen/4) ,outbufi (reclen/4) 
character*! inbufc (reclen) ,outbufc (reclen) 
equivalence (inbufi, inbufc) , (outbufi, outbuf c) 
c 

c— - local storage: 
integer 11,12 
character*80 filename 
character*! cl 
c 

C— - data: (0-no translate, l-real*4, 2-integer*4, 3-ebcdic) 

integer*2 headtyp(557) /4*2, 4 *1, 2*2, 4* 1, 2*2, 6*0, 12*1, 30*3, 3*2, 

> 490*1/ ' 

integer*2 datatyp(756) /5*2, 691*1 , 30*2, 30*0/ 

c 

c— — — functions: 

integer*4 realconv 
c 

c— - constants: 

cl - char(l) 
c 

write (*,*) 'input file:' 
read (*,99901) filename 
99901 format (a80) 

open (21 , file-filename, status- ' old' , 

> access- ' direct ' , form- • format ted' , recl-reclen) 
write (*,*) 'output file:' 

read (*,99901) filename 
open (31 , file-filename, 

> access- ' direct ' , form- ' formatted* , recl-reclen) 


recnum - 1 

100 read (21 , 92101 , rec-recnum, err-200) inbufc 
92101 format (50000a) 

if (inbufc (4) . eq.cl ) then 
do position - 1,557 

goto (104, 101,102, 103), headtyp (position) +1 

101 outbufi (position) - realconv (inbufi (position) ) 

goto 104 

102 il - position*4 

outbuf c (il-3) - inbufc (il ) 
outbufc (il-2) - inbufc (il-1) 
outbufc (il-1 ) - inbufc(il-2) 
outbufc (11) - inbufc (il-3) 
goto 104 

103 il - positlon*4 
do 12 - il-3, il 

outbufc (12) - ascconv (ichar (inbufc (12) } +1) 
end do 

104 end do 
else 

do position - 1,756 

goto (108, 105,106, 107 ) , datatyp (position) +1 

105 outbufi (position) - realconv (inbufi (position) ) 

goto 108 

106 il - position* 4 

outbufc (il-3) - inbufc (il) 
outbufc (il-2) - inbufc (il-1) 
outbufc (il-1) - inbufc (il-2) 
outbufc (il) - inbufc (il-3) 
goto 108 

107 il - position* 4 
do 12 - il-3, il 

outbufc (12) - ascconv(ichar (inbufc (12))+1) 
end do 

108 end do 
end if 

write (31 , 92101, rec-recnum) outbufc 
recnum - recnum+1 
goto 100 
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200 stop 
end 

BLOCK DATA EBC2ASC 
INTEGER* 4 LOOKUP (64) / 

> 50462976, 2139490716, 193891735, 252579084, 319951120, 

> -2029404643,-1886250728, 522067228,-2080599168, 454494852, 

> -1953855096, 117035148,-1827237488, 76977556,-1684366952, 

> 446567700,-1566466016,-1499093053, 777758887, 556476476, 

> -1414078938,-1347506772, 610120112, 1580935466,-1280168147, 

> -1212762700, 746371512, 1061052197,-1111704646,-1044332610, 

> 591028418, 574433088, 1667391939, 1734763876, -976983704, 

> -909588538, 1818979018, 1886350957, -859082127, -791687475, 

> 1953726161, 2021095029, -741180807, -673706412, -606414376, 

> -539042340, -471670304, -404298268, 1128415611, 1195787588, 

> -370652856, -303240214, 1200002685, 1347374669, -269594031, 

> -202182160, 1414766428, 1482118741, -168535463, -101124106, 

> 858927408, 926299444, -67407432, -66052 / 

COMMON /E2ACOM/ LOOKUP 

END 

INTEGER* 4 FUNCTION REALCONV (IBM) 

C 

IMPLICIT NONE 
C 

C— — DUmY STORAGE: 

INTEGER* 4 IBM 
C 

c — « EQUIVALENCE STORAGE: 

INT£GER*4 IIBM 
CHARACTER* 1 CIBM(4) 

EQUIVALENCE (IIBM, C IBM) 

INTEGER*4 IDEC 
CHARACTER* 1 CDEC(4) 

EQUIVALENCE (IDEC,CDEC) 

C 

c— — common storage: 

integer*4 recnum, position 
common /xxyyzz/recnum, position 
c 

C— — LOCAL STORAGE: 

INTEGER COUNT 
LOGICAL SIGNFLAG 
CHARACTER*! CO 
C 

C "CONSTANTS'* 

CO - CHAR (0) 

C 

C MOVE ARGUMENT TO EQUIVALENCE AREA 

IIBM - IBM 
C 

C — — SWITCH MANTISSA BYTES INTO dec 
CDEC (1) - C I BM ( 4 ) 

CDEC ( 2 ) - C I BM ( 3 ) 

CDEC (3) - CIBM (2) 

C 

C— — ZERO NON-MANTISSA BYTE 
CDEC (4) - CO 
C 

C CHECK FOR 0.0 

IF (CDEC (1) .EQ.C0 .AND. CDEC (2) . EQ . CO .AND. CDEC ( 3) . EQ. CO) 

> GOTO 120 

C SHIFT MANTISSA BITS LEFT UNTIL A 1 IS FOUND, DISCARD THE 1, 

C KEEP COUNT 

COUNT - 0 

100 IDEC - ISHFT (IDEC, 1) 

IF (CDEC (4) .NE. CO) GOTO 110 
COUNT - COUNT+1 
GOTO 100 
C 

C— - EXTRACT AND CLEAR SIGN BIT 
110 SIGNFLAG - BTEST (I IBM, 7) 

IIBM - IBCLR (IIBM, 7} 

C 

C CALCULATE NEW EXPONENT 

CIBM ( 2 ) - CO 
CIBM (3) - CO 
Cl BM (4 ) - CO 
IIBM - I IBM* 4 -COUNT-1 30 
IF (IIBM. GT. 255 .OR. IIBM.LT.0) THEN 
write (*,99901) recnum, position 
99901 format ('ibm value out of range in ' , i6, 1 , ' , i 3 ) 
cdec(l) - cO 
cdec(2) - cO 
cdec<3) - cO 
cdec(4) - cO 
goto 120 
END IF 
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— MERGE DEC SIGN, EXPONENT AND MANTISSA 
CDEC (4 ) - CIBM(l) 

IDEC - ISHFT (IDEC, —1 ) 

IF (SIGNFLAG) IDEC - IBSET (IDEC, 31 ) 

120 REALCONV - IDEC 
RETURN 
END 
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